简体   繁体   中英

A double looped autofilter, does that work in Excel VBA?

I've got a set of data from a database imported into an Excel file. This data is from a laser cutter machine for metal. The data I have includes material name, plate thickness and 2 different times (There's more data but those 4 are the ones I need).

The result I want: I want to filter my data on material name first, after that I want to filter my data on plate thickness. In the results of this second filter I want to SUM the time of both timefields and then post the outcome of this in another sheet. So the result in the second sheet should be: Material name, plate thickness, total time of the results in column D, total time of the results in Column E (There is some data in other columns which is irrelevant for this)

Here's a small example of what the data looks like (Data starts on row 3):

Material name(col A)Plate Thickness(col B)Time1(col D)Time2(col E)
RVS 304             25mm                  00:18:14    00:21:48
RVS 304             25mm                  00:30:28    00:39:19
RVS 304             10mm                  00:12:10    00:14:25
S235                10mm                  00:48:32    00:13:33
S235                3mm                   00:10:31    00:02:22

Some other useful information: The Material name my loop is based on is based on my results and filtered on duplicates, so the material name always exists. Plate thickness has a standard amount of items the amount of items in this range is 19 different sizes in millimeters. My lists of filter criteria start on Cell 2, that's why the integer starts from 2 aswell. The result of both autofilters can result in nothing, as not every material name has done every plate thickness.

Something to add on my current code: It almost does the job, alltho it skips some items in the loop through the list of material names and it can't sum up the time. It is also extremely slow so I would like to know if I could make it run faster.

This is my code:

Sub TestSub()
On Error Resume Next
    Worksheets("InformatieData").ShowAllData
On Error GoTo 0
Dim iLoop As Integer

For iLoop = 1 To 20

Worksheets("InformatieData").Range("A2").AutoFilter Field:=1, Criteria1:=Worksheets("InformatieFormules").Cells(iLoop, 1).Value
If Worksheets("InformatieData").AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
    Dim mmLoop As Integer

    For mmLoop = 2 To 20
        Worksheets("InformatieData").Range("A2").AutoFilter Field:=2, Criteria1:=Worksheets("InformatieFormules").Cells(mmLoop, 2).Value
        If Worksheets("InformatieData").AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
            Worksheets("InformatieData").Range("A3:A10000,B3:B10000,D3:D10000,E3:E10000").Copy
            Worksheets("InformatieMMFilterResultaat").Cells(Cells.Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)
        End If
    Next mmLoop
End If
Next iLoop
End Sub

Couldn't test this, but I think it should work, at least until the splitting part (if something goes wrong you could find another way, or just use the interface option for texto to columns):

Option Explicit
Sub Test()

    Dim wsData  As Worksheet, wsOutput As Worksheet, arrData As Variant, SplitRange As Range, i As Long
    'You will need to check Microsoft Scripting Dictionary from your references for this to work:
    Dim DictColD As New Scripting.Dictionary, DictColE As New Scripting.Dictionary

    'Set the worksheets where we will work
    With ThisWorkbook
        Set wsData = .Sheets("InformatieData")
        Set wsOutput = .Sheets("InformatieMMFilterResultaat")
    End With

    'Fill an array with the source data
    arrData = wsData.UsedRange.Value 'this will get everything on the worksheet till the last used cell

    'Lets assume, as you said that the order and position of the columns is A to E
    For i = 2 To UBound(arrData) '2 because 1 is headers
        'if the material with the thickness doesn't exist yet, add it along with its time on column D
        If Not DictColD.Exists(arrData(i, 1) & "-" & arrData(i, 2)) Then
            DictColD.Add arrData(i, 1) & "-" & arrData(i, 2), arrData(i, 4) 'Column D value
        Else
        'If the material with the thickness already exists, then sum its time on column D
            DictColD(arrData(i, 1) & "-" & arrData(i, 2)) = DictColD(arrData(i, 1) & "-" & arrData(i, 2)) + arrData(i, 4)
        End If

        'Now the same for column E
        'if the material with the thickness doesn't exist yet, add it along with its time on column E
        If Not DictColE.Exists(arrData(i, 1) & "-" & arrData(i, 2)) Then
            DictColE.Add arrData(i, 1) & "-" & arrData(i, 2), arrData(i, 5) 'Column E value
        Else
        'If the material with the thickness already exists, then sum its time on column E
            DictColE(arrData(i, 1) & "-" & arrData(i, 2)) = DictColE(arrData(i, 1) & "-" & arrData(i, 2)) + arrData(i, 5)
        End If
    Next i

    Erase arrData

    'Now you've got 2 dictionaries along with all the data you need, you only need to throw it back to your sheet
    With wsOutput 'I'm going to assume you already have the headers there so only the data will be pasted
        .Cells(2, 1).Resize(DictColD.Count) = Application.Transpose(DictColD.Keys) 'Material & Thickness
        .Cells(2, 4).Resize(DictColD.Count) = Application.Transpose(DictColD.Items) 'Col D Times
        .Cells(2, 5).Resize(DictColE.Count) = Application.Transpose(DictColE.Items) 'Col E Times
        'Now we need to separate material & thickness into 2 columns
        Set SplitRange = .Range("A2", .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1))
        SplitRange.TextToColumns Destination:=SplitRange, DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="-", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
    End With

End Sub

This should be fairly faster than your actual code since it's working everything on memory.

The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM