Search code examples
excelvba

Excel VBA Loop Copy/paste, autofilter, return value and loop


This doesn't seem to work.

I have one (1) Workbook, Sheet1, then other sheets named "1","2"...."15".
Sheet1 is where my main data is, while the other sheets contains data I want to filter.

I want to loop through all rows in Sheet1 and filter them individually in the other sheets. While looping, I want to make sure the value in cell "G" in Sheet1 matches the other worksheet names.
Then paste it, and call a function/sub to autofilter (I already have this figured out).
Then return the number of rows returned from the filter to cell "H" of Sheet1, that was filtered.

I need all this to be a loop.

Sub DataAnalysis()

    Sub ArrayBuilder() 'Loops through all rows and copy
        myarray = Range("A1:M1000")
        
        For i = 1 To UBound(myarray)
            For j = 1 To UBound(myarray, 2)
                Debug.Print (myarray(i, j))
            Next j
        Next i
            
        Dim wkSht As Worksheet
        For Each wkSht In Sheets
            X = Range("G1:G1000")
            
            For i = 1 To UBound(myarray)
                For j = 1 To UBound(myarray, 2)
                    Debug.Print (myarray(i, j))
                Next j
            Next i
            
            If Sheets("Sheet1").Range(X).Value = wkSht.Name Then  'if value of G in rows (that has been looped through)
                'matches the worksheet name, then paste
                Sheets("Sheet1").Rows("2:2").Paste
                Application.CutCopyMode = False
            End If
        Next
    
        Application.Run "'FileX.xls'!FilterX"    ' this activates a macro for autofilter and run it, 

        ' I can also paste the code here but that is not the problem right now
        X1 = Range("H1:H1000")
       
        For i = 1 To UBound(myarray)
            For j = 1 To UBound(myarray, 2)
                Debug.Print (myarray(i, j))
            Next j
        Next i
        
        Sheet1.Range(X1).Value = ws.AutoFilter.Range.Columns(1) ' returns the row count on the filtered data to cell H for every loop
    End Sub

End Sub

EDIT*** The CODE THAT FILTERS - FILTERX MACRO

Sub FilterX()
    If ActiveSheet.FilterMode = True Then
    ActiveSheet.ShowAllData
    End If
    
    Dim L(2) As String
    Dim M(2) As String
    Dim N(2) As String
    Dim O(2) As String
    Dim P(2) As String
    Dim Q(2) As String
    Dim R(2) As String
    Dim T(2) As String
    Dim U(2) As String
    Dim V(2) As String
    Dim W(2) As String
    Dim X(2) As String
    Dim Y(2) As String
    Dim Z(2) As String    
        
        L(0) = Cells(2, 12).Value
        L(1) = Cells(2, 12).Value + 1
        L(2) = Cells(2, 12).Value - 1
        
        M(0) = Cells(2, 13).Value
        M(1) = Cells(2, 13).Value + 1
        M(2) = Cells(2, 13).Value - 1
        
        N(0) = Cells(2, 14).Value
        N(1) = Cells(2, 14).Value + 1
        N(2) = Cells(2, 14).Value - 1
        
        O(0) = Cells(2, 15).Value
        
        P(0) = Cells(2, 16).Value
        P(1) = Cells(2, 16).Value + 1
        P(2) = Cells(2, 16).Value - 1
        
        Q(0) = Cells(2, 17).Value
        Q(1) = Cells(2, 17).Value + 1
        Q(2) = Cells(2, 17).Value - 1
        
        R(0) = Cells(2, 18).Value
        R(1) = Cells(2, 18).Value + 1
        R(2) = Cells(2, 18).Value - 1
        
        
        T(0) = Cells(2, 20).Value
        T(1) = Cells(2, 20).Value + 1
        T(2) = Cells(2, 20).Value - 1
        
        U(0) = Cells(2, 21).Value
        U(1) = Cells(2, 21).Value + 1
        U(2) = Cells(2, 21).Value - 1
        
        
        V(0) = Cells(2, 22).Value
        V(1) = Cells(2, 22).Value + 1
        V(2) = Cells(2, 22).Value - 1
        
        W(0) = Cells(2, 23).Value
        
        X(0) = Cells(2, 24).Value
        X(1) = Cells(2, 24).Value + 1
        X(2) = Cells(2, 24).Value - 1
        
        
                
        Y(0) = Cells(2, 25).Value
        Y(1) = Cells(2, 25).Value + 1
        Y(2) = Cells(2, 25).Value - 1
        
        Z(0) = Cells(2, 26).Value
        Z(1) = Cells(2, 26).Value + 1
        Z(2) = Cells(2, 26).Value - 1
        
        
    'ActiveSheet.Range("A1:AZ1048576").AutoFilter Field:=12, Operator:=xlFilterValues, Criteria1:=L()
    ActiveSheet.Range("A1:AZ1048576").AutoFilter Field:=13, Operator:=xlFilterValues, Criteria1:=M()
    'ActiveSheet.Range("A1:AZ1048576").AutoFilter Field:=14, Operator:=xlFilterValues, Criteria1:=N()
    ActiveSheet.Range("A1:AZ1048576").AutoFilter Field:=15, Operator:=xlFilterValues, Criteria1:=O()
    'ActiveSheet.Range("A1:AZ1048576").AutoFilter Field:=16, Operator:=xlFilterValues, Criteria1:=P()
    'ActiveSheet.Range("A1:AZ1048576").AutoFilter Field:=17, Operator:=xlFilterValues, Criteria1:=Q()
    ActiveSheet.Range("A1:AZ1048576").AutoFilter Field:=18, Operator:=xlFilterValues, Criteria1:=R()
    'ActiveSheet.Range("A1:AZ1048576").AutoFilter Field:=20, Operator:=xlFilterValues, Criteria1:=T()
    ActiveSheet.Range("A1:AZ1048576").AutoFilter Field:=21, Operator:=xlFilterValues, Criteria1:=U()
    'ActiveSheet.Range("A1:AZ1048576").AutoFilter Field:=22, Operator:=xlFilterValues, Criteria1:=V()
    ActiveSheet.Range("A1:AZ1048576").AutoFilter Field:=23, Operator:=xlFilterValues, Criteria1:=W()
    'ActiveSheet.Range("A1:AZ1048576").AutoFilter Field:=24, Operator:=xlFilterValues, Criteria1:=X()
    'ActiveSheet.Range("A1:AZ1048576").AutoFilter Field:=25, Operator:=xlFilterValues, Criteria1:=Y()
    ActiveSheet.Range("A1:AZ1048576").AutoFilter Field:=26, Operator:=xlFilterValues, Criteria1:=Z()
              
End Sub

Solution

  • Best guess, it should help make progress.

    Update 1 - added FilterX macro

    Update 2 - revised FilterX

    Update 3 - When there's an error code moves to next

    Sub DataAnalysis()
    
        Dim ws As Worksheet, rng As Range
        Dim r As Long, lastRowG As Long, s As String
        Dim dict As Object
        Set dict = CreateObject("Scripting.Dictionary")
        
        ' Built dictionary of sheet names
        For Each ws In Sheets
            dict.Add ws.Name, ws.Index
        Next
        
        ' scan sheet
        With Sheets("Sheet1")
            lastRowG = .Cells(.Rows.Count, "G").End(xlUp).Row
            For r = 1 To lastRowG
                s = .Cells(r, "G")
                ' check valid
                If dict.exists(s) Then
    
                    Set ws = Sheets(s)
                    .Rows(r).Copy ws.Rows(2)
                    
                    ' apply filter and return record count
                    .Cells(r, "H") = FilterX(ws)
                    
                ElseIf Len(s) > 0 Then
                    MsgBox "Invalid sheet name: " & s, vbInformation, "Row " & r
                    Exit Sub
                End If
            Next
        End With
        
        MsgBox lastRowG & " rows scanned in col G", vbInformation
    
    End Sub
    
    Function FilterX(ws As Worksheet) As Long
    
        Dim rng As Range, dict, c
        Dim lastrow As Long, n As Long
        Set dict = CreateObject("Scripting.Dictionary")
        
        ' configure filter column, tolerance
        With dict
        '   .Add "L"
            .Add "M", 0 ' +/- 0
        '   .Add "N",
            .Add "O", 1 ' +/- 1
        '   .Add "P",
        '   .Add "Q",
            .Add "R", 2
        '   .Add "S",
        '   .Add "T",
            .Add "U", 1
        '   .Add "V",
            .Add "W", 1
        '   .Add "X",
        '   .Add "Y",
            .Add "Z", 2
        End With
    
        With ws
            ' remove filter
            If .FilterMode = True Then .ShowAllData
           
            ' apply fliter
            lastrow = .UsedRange.Row + .UsedRange.Rows.Count - 1
            If lastrow < 3 Then
                 FilterX = 0
                 Exit Function
            End If
            
            Set rng = .Range("A1:AZ" & lastrow)
            'Debug.Print ws.Name, rng.Address
            
            ' apply filter to columns M, O, R, U, W, Z
            For Each c In dict.keys
                n = Cells(1, c).Column ' column number
                ' dict(c) is tolerance +/- on rows 2 value
                rng.AutoFilter Field:=n, Criteria1:=">=" & (.Cells(2, n) - dict(c)), _
                        Operator:=xlAnd, Criteria2:="<=" & (.Cells(2, c) + dict(c))
            Next
            
            ' return count
            On Error Resume Next 'skips error code when no cells are found
            FilterX = .Range("A3:A" & lastrow).SpecialCells(xlCellTypeVisible).Count
        End With
        
    End Function