ハイライトされたセルとシート名をコピー先のワークシートにコピー

Question

2つの条件を満たすセル値をコピーしようとしています：（1）ハイライトされた行、（2）特定のリージョンコード"WA"。列Bのセル値を列Aのヘッダーの下の宛先ワークシートにコピーする必要があります。さらに、条件を満たす値に対応するシート名を列Cにコピーして宛先ワークシートにコピーします。

• をできるだけ早く私はそれが動作しますが、先のシートに任意の値を超えていません。このコードを追加する：私が遭遇した

  問題。 LCase(Cells(Cell.Row, "A").Value) = "wa"

• 上記のコード行を削除し、列2に表示されるように対象領域を変更すると、ヘッダーの下に開始するのではなく、列Bでハイライトされた値が列挙され、A1から開始して貼り付けられます。

部分ターゲットエリア（フル対象領域がこれらの列を下って行く異なる地域コードと値を持つ）：

Sub Criteria() 
Application.ScreenUpdating = False 
Application.DisplayAlerts = False 

Dim wkb As Workbook 
Dim Sh As Worksheet 
Dim DestSh As Worksheet 
Dim LastRow As Long, LastCol As Long, Last As Long 
Dim Target As Range, Cell As Range, Dest As Range 
Dim DestCounter As Long 

' Delete the data off of AdvFilter sheet. 
ActiveWorkbook.Worksheets("AdvFilter").Range("A5:F5" & Last + 1).Cells.Clear 
On Error GoTo 0 

'initialize destination counter 
DestCounter = 1 
Set DestSh = ThisWorkbook.Worksheets("AdvFilter") 
For Each Sh In ThisWorkbook.Worksheets 
    If ActiveSheet.Visible = True Then 

    Last = fLastRow(DestSh) 

    With Sh 
    LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row 
    Set Target = .Range(.Cells(1, 1), .Cells(LastRow, 2)) 
    End With 

     For Each Cell In Target '<~ loop through each cell in the target space 
      If AmIYellow(Cell) And Cell.Value <> "" And _ 
      LCase(Cells(Cell.Row, "A").Value) = "wa" Then 
       Set Dest = DestSh.Cells(Last + DestCounter, 1) 
       Cell.Copy Dest 
       DestCounter = DestCounter + 1 
      End If 
     Next Cell 

    End If 
Next Sh 
Application.DisplayAlerts = True 
Application.ScreenUpdating = True 

End Sub 

Function fLastRow(Sh As Worksheet) 
    On Error Resume Next 
    LastRow = Sh.Cells.Find(What:="*", _ 
          After:=Sh.Range("A1"), _ 
          Lookat:=xlPart, _ 
          LookIn:=xlFormulas, _ 
          SearchOrder:=xlByRows, _ 
          SearchDirection:=xlPrevious, _ 
          MatchCase:=False).Row 
    On Error GoTo 0 
End Function 

Answer 1

あなただけのデータではなく、フォーマットが必要な場合は、配列を使用してデータを収集し、すべてのデータを1回の操作でターゲット範囲に書き込む方がよいでしょう。

Sub Criteria() 
    Dim ws As Worksheet 
    Dim r As Range 
    Dim x As Long 
    Dim Data 
    ReDim Data(1 To 2, 1 To 1) 

    With ActiveWorkbook.Worksheets("AdvFilter") 
     .Range(.Range("A" & .Rows.Count).End(xlUp), "F5").Cells.Clear 
    End With 

    For Each ws In ThisWorkbook.Worksheets 
     If ws.Visible = xlSheetVisible Then 
      With ws 
       For Each r In .Range("A2", .Range("A" & .Rows.Count).End(xlUp)) 
        If LCase(r.Value) = "wa" And r.Interior.ColorIndex = 6 Then 
         x = x + 1 
         ReDim Preserve Data(1 To 2, 1 To x) 
         Data(1, x) = r.Offset(0, 1) 
         Data(2, x) = ws.Name 

        End If 
       Next 
      End With 
     End If 
    Next 

    With ActiveWorkbook.Worksheets("AdvFilter") 
     With .Range("A" & .Rows.Count).End(xlUp).Offset(1) 

      If x > 0 Then .Resize(x, 2).Value = Application.Transpose(Data) 

     End With 
    End With 
End Sub