Excel VBA copiando linhas de usar o autofiltro
-
23-12-2019 - |
Pergunta
Olhando para linhas de cópia de todas as folhas, além da minha planilha ativa que atendem a determinados critérios na coluna J usando o VBA.
Não tem experiência em escrever código em VBA então, eu tenho tentado frankenstein juntos as peças necessárias ao olhar através de outras perguntas e respostas;
abaixo está o código que eu escrevi até agora;
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
Onde Controlada é a folha que eu deseja exibir os dados de outras planilhas, e todas as outras folhas são procuradas para ver se a sua coluna J cumpre os critérios="Y"
Eu não precisa copiar a formatação de todas as Folhas terão a formatação exatamente o mesmo e, se possível, eu quero as linhas que são copiadas para iniciar na linha 3
Solução
Tente isso:
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
Eu acho que isso cobre tudo, ou a maior parte de sua exigência.
Não testado embora assim que eu deixá-lo para você.
Se você de deparar-se com problemas, deixe-me saber.