자동 필터를 사용하여 행 VBA 복사 행을 복사합니다

Question

VBA를 사용하여 컬럼 j에서 특정 기준을 충족시키는 활성 시트와 함께 모든 시트에서 행을 복사하려고합니다.

VBA에서 코드를 작성하는 데 경험되지 않아서 Frankenstein을 다른 질문과 답변을 통해 필요한 부분을 함께 시도했습니다.

아래에서 내가 작성한 코드는 다음과 같습니다.

Sub CommandButton1_Click()

  Dim lngLastRow As Long
  Dim ws As Worksheet
  Dim r As Long, c As Long
  Dim wsRow As Long

  Set Controlled = Sheets("Controlled") ' Set This to the Sheet name you want all Ok's     going to

  Worksheets("Controlled").Activate
  r = ActiveSheet.Cells(Rows.Count, 2).End(x1up).Row
  c = ActiveSheet.Cells(1, Columns.Count).End(x1ToLeft).Column
  Range("J").AutoFilter

  For Each ws In Worksheets
    If ws.Name <> "Controlled" Then
       ws.Activate
       wsRow = ActiveSheet.Cells(Rows.Count, 2).End(x1up).Row + 1
       Range("A" & r).AutoFilter Field:=10, Criteria1:="Y"
       .Copy Controlled.Range("A3" & wsRow)
    End If 
  Next ws
End If


Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

End Sub

.

여기서는 데이터가 다른 시트에서 데이터가 나타나고 다른 모든 시트를 검색하여 열 J가 CRITERIA="Y"

에 충족되는지 확인합니다.

모든 시트가 정확히 동일한 서식을 갖게되면 서식을 복사 할 필요가 없으며 가능한 경우 행 3

행에서 시작되도록 복사 된 행을 원합니다.

Answer 1

시도 :

Option Explicit
Sub ConsolidateY()

Dim ws As Worksheet, wsCtrl As Worksheet
Dim lrow As Long, rng As Range

Set wsCtrl = Thisworkbook.Sheets("Controlled")

With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

For Each ws In Thisworkbook.Worksheets
    If ws.Name = "Controlled" Then GoTo nextsheet
    With ws
        lrow = .Range("J" & .Rows.Count).End(xlUp).Row
        .AutoFilterMode = False
        Set rng = .Range("J1:J" & lrow).Find(what:="Y", after:=.Range("J" & lrow))
        If rng Is Nothing Then GoTo nextsheet
        .Range("J1:J" & lrow).AutoFilter Field:=1, Criteria1:="Y"
        .Range("J1:J" & lrow).Offset(1,0).SpecialCells(xlCellTypeVisible).EntireRow.Copy
        wsCtrl.Range("A" & wsCtrl.Rows.Count).End(xlUp).Offset(1,0).PasteSpecial xlPasteValues
        .AutoFilterMode = False
        Application.CutCopyMode = False
    End With
nextsheet:
Next

With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
End With

End Sub

.

나는 이것이 당신의 모든 것을 포함하거나 대부분의 요구 사항을 다루고 있다고 생각합니다.
테스트를하지 않으므로 나는 그것을 당신에게 맡깁니다.
문제가 해결되면 알려주세요.