VBA autofilter loop macro amendment

[Legacy 397974]

Hello, I am trying to write a macro, which will loop through all headers in a specific sheet and in case last 12 characters are "_TEAM_OFFICE", it will copy/paste the filtered results into another sheet. Same procedure will go for all other columns in range. Unfortunately, my code doesn't seem to be working properly. I'd do appreciate some help. Thanks.

Sub Copydata()

Dim erow As Long


Sheets("Raw Data").Select


    Set MR = Sheets("Raw Data").Range("A1:zz1")
    For Each cell In MR
    erow = Sheet3.Range("a" & Rows.Count).End(xlUp).Row + 1
        If Right(cell.Value, 12) = "_TEAM_OFFICE" Then cell.AutoFilter Field:=1, Criteria:="UB"
        'cell.EntireRow.Copy Destination:=Sheet3.Range("a" & erow)
       'cell.AutoFilter.Range.Copy Destination:=Sheet3.Range("a" & erow)
        .SpecialCells(xlCellTypeVisible).Copy Destination:=Sheet3.Range("a" & erow)
    Next
End Sub

 

[vbanoob0807]

Hi Jojyina,

assuming you want all the filtered results to be copied into sheet 3(appended) with headers to appeared only once, try the code below:

Sub Copydata()

Dim erow As Long
Dim c As Long
Dim MR As Range
Dim RngToFilter As Range
Dim ShtRawData As Worksheet
Dim Sht3 As Worksheet
Dim b As Boolean

    Set ShtRawData = ThisWorkbook.Worksheets("Raw Data")
    c = ShtRawData.Cells(1, Columns.Count).End(xlToLeft).Column
    Set MR = ShtRawData.Range("A1:A" & c)
    Set RngToFilter = ShtRawData.UsedRange
    Set Sht3 = ThisWorkbook.Worksheets(3)
    b = False
    
    For Each cell In MR.Cells
    
        If Sht3.Range("A1").Value = "" Then
            
            erow = Sht3.Range("A" & Rows.Count).End(xlUp).Row
            
        Else
        
            b = True
            erow = Sht3.Range("A" & Rows.Count).End(xlUp).Row + 1
        
        End If
        
        If Right(cell.Value, 12) = "_TEAM_OFFICE" Then
        
            RngToFilter.AutoFilter 1, "UB"
            
            If b = True Then
                RngToFilter.Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy Sht3.Range("A" & erow)
            Else
                RngToFilter.SpecialCells(xlCellTypeVisible).Copy Sht3.Range("A" & erow)
            End If
            
        End If
        
        If RngToFilter.AutoFilter = True Then RngToFilter.AutoFilter
        
    Next

End Sub

 

[Legacy 397974]

Thank you vbanoob807 for your insights, however the macro doesn't seem to be copying the data from my tab, after run it simply retrieves no data.

 

[vbanoob0807]

Hi, i amend a mistake, can you try:

Sub Copydata()

Dim erow As Long
Dim c As Long
Dim MR As Range
Dim RngToFilter As Range
Dim ShtRawData As Worksheet
Dim Sht3 As Worksheet
Dim b As Boolean

    Set ShtRawData = ThisWorkbook.Worksheets("Raw Data")
    c = ShtRawData.Cells(1, Columns.Count).End(xlToLeft).Column
    Set MR = ShtRawData.Range(Cells(1, 1), Cells(1, c))
    Set RngToFilter = ShtRawData.UsedRange
    Set Sht3 = ThisWorkbook.Worksheets(3)
    b = False
    
    For Each cell In MR.Cells
    
        If Sht3.Range("A1").Value = "" Then
            
            erow = Sht3.Range("A" & Rows.Count).End(xlUp).Row
            
        Else
        
            b = True
            erow = Sht3.Range("A" & Rows.Count).End(xlUp).Row + 1
        
        End If
        
        If Right(cell.Value, 12) = "_TEAM_OFFICE" Then
        
            RngToFilter.AutoFilter 1, "UB"
            
            If b = True Then
                RngToFilter.Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy Sht3.Range("A" & erow)
            Else
                RngToFilter.SpecialCells(xlCellTypeVisible).Copy Sht3.Range("A" & erow)
            End If
            
        End If
        
        If RngToFilter.AutoFilter = True Then RngToFilter.AutoFilter
        
    Next

End Sub

 

[Legacy 397974]

Many thanks again, although the code seems to be copying only the headers to Sheet3 right now.

 

[vbanoob0807]

Hi, i think the logic is wrong as i follow your initial code,

If Right(cell.Value, 12) = "_TEAM_OFFICE" Then cell.AutoFilter Field:=1, Criteria:="UB"

it tells me that for each header that ends with "_TEAM_OFFICE", you want to filter column 1 that contains "UB". This will give you repeated data in sheet 3.

Say, there are 49 headers that ends with "_TEAM_OFFICE",

each header filters column 1(Fixed: always column 1) that contains "UB", which say there are 100 rows,

there will be total of 4900 rows + 1 header on sheet 3.

Or, is it you that want to filter each header(ends with "_TEAM_OFFICE") for "UB" ?

 

[Legacy 397974]

Sorry, I am afraid, that my logic was indeed wrong. The macro will copy all values from fixed column, which was not an intention. I'd like the macro to filter each header ending with "_TEAM_OFFICE" and then copy the data to sheet3.

 

[vbanoob0807]

Hi, try this

Sub Copydata()

Dim erow As Long
Dim c As Long
Dim MR As Range
Dim RngToFilter As Range
Dim ShtRawData As Worksheet
Dim Sht3 As Worksheet
Dim b As Boolean

    Set ShtRawData = ThisWorkbook.Worksheets("Raw Data")
    c = ShtRawData.Cells(1, Columns.Count).End(xlToLeft).Column
    Set MR = ShtRawData.Range(Cells(1, 1), Cells(1, c))
    Set RngToFilter = ShtRawData.UsedRange
    Set Sht3 = ThisWorkbook.Worksheets(3)
    b = False
    
    For Each cell In MR.Cells
    
        If Sht3.Range("A1").Value = "" Then
            
            erow = Sht3.Range("A" & Rows.Count).End(xlUp).Row
            
        Else
        
            b = True
            erow = Sht3.Range("A" & Rows.Count).End(xlUp).Row + 1
        
        End If
        
        If Right(cell.Value, 12) = "_TEAM_OFFICE" Then
        
            RngToFilter.AutoFilter [COLOR=#ff0000]cell.Column[/COLOR], "UB"
            
            If b = True Then
                RngToFilter.Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy Sht3.Range("A" & erow)
            Else
                RngToFilter.SpecialCells(xlCellTypeVisible).Copy Sht3.Range("A" & erow)
            End If
            
        End If
        
        If RngToFilter.AutoFilter = True Then RngToFilter.AutoFilter
        
    Next
    
[COLOR=#0000cd]Sht3.Activate[/COLOR]

End Sub

I amended a line in red, and added a line in blue. See if it works.

 

[Legacy 397974]

Thank you very much, the codes works exactly as desired. That's really great help.