[Solved]Complex Filtering & Copying With VBA (Need Help)

[Nctukek]

Hey All,

I am attempting to create a sort of complex selection system with VBA and could really use some help. The primary goal I am trying to achieve(there are a couple of filters I need to create) is to find the most recent order # a certain customer is mentioned so that I can copy some information from that particular line into a sort of summary sheet. The information I am filtering through is spread over multiple tabs which adds another level of complexity. I'm relatively new to VBA so this is particularly daunting to me as I am not very familiar with the syntax.

I have attached an example of what I would like the end result to look like to this post, please let me know if you have any questions. Any advice on coding and syntax to achieve this would be great.

VBA Filter+Summary Example.zip

Thanks for your help!
-Nctukek

[vbfbryce]

Will your tabs always be in chronological order like that?

[Nctukek]

Yes. The original worksheet covers an entire fiscal year (Apr - Mar).

[vbfbryce]

If you start out with NO summary sheet, try this:

Sub summarize()
    Dim wb As Workbook
    Dim wsSum As Worksheet
    Dim wsMonth As Worksheet
    Dim cust As String
    Dim j As Integer
    Dim k As Integer
    Dim m As Integer
    Dim n As Integer
    Dim rngSort As Range
    Dim rngKey1 As Range
    Dim rngKey2 As Range
    Dim lr As Long
    Dim arrCust() As String
    Dim custCount As Integer
    Dim dontWrite As Boolean
    Dim writeRow As Long
    
    Set wb = ActiveWorkbook
    Set wsSum = wb.Worksheets.Add(after:=wb.Worksheets(wb.Worksheets.Count))    'add sheet
    wsSum.Name = "Summary"
    With wsSum      'put header values in row 1
        .Range("a1").Value = "Date Ordered"
        .Range("b1").Value = "Order #"
        .Range("c1").Value = "Customer"
        .Range("d1").Value = "Buyer"
        .Range("e1").Value = "Order Total"
        .Range("f1").Value = "Order Description"
    End With
    
    custCount = -1
    
    With wb
        For j = .Worksheets.Count - 1 To 1 Step -1
            Set wsMonth = .Worksheets(j)
            lr = wsMonth.Range("a" & Rows.Count).End(xlUp).Row      'find last row of dat
            Set rngKey1 = wsMonth.Range("c2:c" & lr)    'sort key 1: customer
            Set rngKey2 = wsMonth.Range("a2:a" & lr)    'sort key 2: date
            Set rngSort = wsMonth.Range("a1:f" & lr)    'overall sort range
            With wsMonth.Sort
                .SortFields.Clear
                .SortFields.Add Key:=rngKey1    'sort first by customer
                .SortFields.Add Key:=rngKey2    'then by date
                .SetRange rngSort
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
            For k = 2 To lr
                With wsMonth
                    If .Range("c" & k).Value <> .Range("c" & k + 1).Value Then
                        'only 1 order for this customer in this month
                        cust = .Range("c" & k).Value
                        If custCount > -1 Then
                            'see if this customer is already in summary sheet
                            For m = 0 To custCount - 1
                                If cust = arrCust(m) Then
                                    'customer already in summary sheet
                                    
                                    dontWrite = True
                                    Exit For
                                End If
                            Next m
                            If dontWrite = False Then
                                'write to summary and to array
                                ReDim Preserve arrCust(custCount)
                                arrCust(custCount) = cust
                                custCount = custCount + 1
                                writeRow = wsSum.Range("a" & Rows.Count).End(xlUp).Row + 1
                                For n = 1 To 6
                                    wsSum.Cells(writeRow, n) = .Cells(k, n)
                                Next n
                            Else
                                dontWrite = False
                            End If
                        Else
                            ReDim arrCust(0)
                            arrCust(0) = cust
                            custCount = 1
                            writeRow = wsSum.Range("a" & Rows.Count).End(xlUp).Row + 1
                            For n = 1 To 6
                                wsSum.Cells(writeRow, n) = .Cells(k, n)
                            Next n
                        End If
                    Else
                        'more than one order in this month for this customer
                    End If
                End With
            Next k
        Next j
        With wsSum
            lr = .Range("a" & Rows.Count).End(xlUp).Row
            .Range("a2:a" & lr).NumberFormat = "m/d/yy;@"
            .Range("a1:f1").EntireColumn.AutoFit
        End With
    End With
    
End Sub

[Nctukek]

Works like a charm!

Thanks for the help