강조 표시된 셀 및 시트 이름을 대상 워크 시트에 복사

Question

두 조건을 충족하는 셀 값을 복사하려고합니다. (1) 강조 표시된 행, (2) 특정 지역 코드가 있습니다. "WA". 열 B의 셀 값을 열 A의 머리글 아래에있는 대상 워크 시트로 복사해야합니다. 또한 조건을 충족하는 값에 해당하는 시트 이름을 열 C에 복사하여 대상 워크 시트에 복사합니다.

문제 나 발생했습니다 : 최대한 빨리 그것을 실행되지만 대상 시트에 대한 값을 통과하지 않는 코드를 추가로

• .
• 위의 코드 줄을 제거하고 대상 영역을 열 2 Set Target = .Range(.Cells(1, 2), .Cells(LastRow, 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

사용자는 데이터 만이 아닌 포맷을해야하는 경우를; 배열을 사용하여 데이터를 수집하고 한 번의 작업으로 모든 데이터를 대상 범위에 쓰는 것이 더 나을 것입니다.

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