VBA to filter on 2 columns and consolidate data into one row

sncb

Board Regular
Joined
Mar 17, 2011
Messages
160
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
I have data sets that look like this below and pasted from A2 onwards with fixed no of columns but varying no of rows..

1617287505419.png


and need to process it in such a way that VB would first filter on Col J and then on Col E for unique values (like below)

1617287761061.png


and from the resulting value remove duplicates and consolidate it into the top row while summing up totals in col L for only the filtered values as shown:

1617288024781.png


and then continue the process to filter on next value of E (while still filtered on the first value of J)

1617288271988.png


to get:
1617288509918.png


and then the filter on next value in Col J and Col E again and so on...such that when i paste the data and run VB, I am able to get something like this:

1617289114604.png


I know this is a bit complicated but if anyone could help out this would be great for my work purposes. I've tried recording the process as a macro but it records actual values which I cannot use as the data in each such data set that i process has different values.

Tia to anyone who could help out.

Here is the raw data if it might help.

CcodeCountryCodeShortRegionZipStateDogIDDogTypeOwnerColorContinentValue
1​
USAUnited StatesNorthAm
99999​
Texas
4412​
TerrierMartinezGreenAmericas
5​
1​
USAUnited StatesNorthAm
99999​
Texas
4412​
TerrierHernandezGreenAmericas
10​
1​
USAUnited StatesNorthAm
99999​
Texas
4916​
GerShepLopezGreenAmericas
15​
1​
USAUnited StatesNorthAm
77777​
Michigan
4916​
GerShepGonzalezGreenAmericas
20​
1​
USAUnited StatesNorthAm
77777​
Michigan
4919​
GerShepWilsonGreenAmericas
5​
1​
USAUnited StatesNorthAm
77777​
Michigan
4920​
CollieJohnsonGreenAmericas
10​
1​
USAUnited StatesNorthAm
77777​
Michigan
4920​
CollieWilliamsGreenAmericas
15​
1​
USAUnited StatesNorthAm
55555​
Georgia
5326​
DobermanBrownWhiteAmericas
20​
1​
USAUnited StatesNorthAm
55555​
Georgia
5326​
DobermanJonesWhiteAmericas
5​
1​
USAUnited StatesNorthAm
55555​
Georgia
7060​
StrayGarciaWhiteAmericas
10​
1​
USAUnited StatesNorthAm
55555​
Georgia
7060​
StrayMillerWhiteAmericas
15​
1​
USAUnited StatesNorthAm
33333​
Montana
8837​
PomDavisWhiteAmericas
20​
1​
USAUnited StatesNorthAm
33333​
Montana
3249​
HoundRodriguezWhiteAmericas
5​
1​
USAUnited StatesNorthAm
33333​
Montana
8495​
GoldRetSmithWhiteAmericas
10​
 

Attachments

  • 1617287990662.png
    1617287990662.png
    18.6 KB · Views: 8
  • 1617288230858.png
    1617288230858.png
    14.9 KB · Views: 7
  • 1617288826105.png
    1617288826105.png
    59.4 KB · Views: 9
Last edited:

Excel Facts

What did Pito Salas invent?
Pito Salas, working for Lotus, popularized what would become to be pivot tables. It was released as Lotus Improv in 1989.
See if this gets you close to what you need. Using your raw data copied to "Sheet1", the code writes the results to "Sheet2". It is a little busy at best, but it tested successfully on your raw data.

VBA Code:
Sub Dogs()
    
    Dim arrJ, arrE, arr
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim x As Long, i As Long, y As Long, lRow As Long, G As Long, H As Long, lRow2 As Long
    Dim ct As Long, b As Long
    Dim rng As Range, rng2 As Range, rngsum As Range
    Dim str As String
    
    Application.ScreenUpdating = False
    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")
    Set rng2 = ws1.UsedRange.Offset(1, 0)
    arrJ = rng2
    arrE = rng2
    With CreateObject("Scripting.Dictionary")
    For x = LBound(arrJ) To UBound(arrJ) - 1
        If Not IsMissing(arrJ(x, 10)) Then .Item(arrJ(x, 10)) = 1
    Next
    arrJ = .Keys
    End With
    With CreateObject("Scripting.Dictionary")
    For y = LBound(arrE) To UBound(arrE) - 1
        If Not IsMissing(arrE(y, 5)) Then .Item(arrE(y, 5)) = 1
    Next
    arrE = .Keys
    End With
    
    For i = LBound(arrJ) To UBound(arrJ)
        For b = LBound(arrE) To UBound(arrE)
            ws1.Activate
            rng2.AutoFilter
            ws1.Range("J1").AutoFilter
            ws1.UsedRange.AutoFilter Field:=10, Criteria1:=arrJ(i), Operator:=xlFilterValues
            ws1.UsedRange.AutoFilter Field:=5, Criteria1:=arrE(b), Operator:=xlFilterValues
            Set rng = ActiveSheet.AutoFilter.Range
            lRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1
            rng.Offset(1, 0).Copy ws2.Range("A" & lRow)
            ws2.Activate
            lRow2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row
            If lRow2 < lRow Then GoTo skip
            Set rngsum = Range("L" & lRow & ":L" & lRow2)
            ct = WorksheetFunction.Sum(rngsum)
            For G = 7 To 9
                arr = ws2.Range("A" & lRow & ":L" & lRow2)
                With CreateObject("Scripting.Dictionary")
                    For x = LBound(arr) To UBound(arr)
                        If Not IsMissing(arr(x, G)) Then .Item(arr(x, G)) = 1
                    Next
                    arr = .Keys
                End With
                For H = LBound(arr) To UBound(arr)
                    str = str & vbNewLine & arr(H)
                Next
                str = Mid(str, 3)
                Cells(lRow, G) = str
                str = ""
            Next
            Range("L" & lRow) = ct
            Range("A" & lRow + 1 & ":A" & lRow2).EntireRow.Delete
skip:
        Next
    Next
    ws1.Range("A1:L1").Copy ws2.Range("A1")
    ws1.AutoFilter.ShowAllData
    Application.ScreenUpdating = True
    
End Sub

I hope this helps.
 
Upvote 0
Hi igold,

Thanks for taking the time to do this.

So when i run the macro on the first attempt, I get this error and the original data gets filtered on the first value in Col J and nothing is pasted in Sheet2

1617489064995.png


1617489089019.png



However when I remove the filter on col J to show all values again and rerun the code, I get this error below and again nothing is created in Sheet2.

1617489250377.png


1617489268579.png


Thanks again for this.
 
Upvote 0
I can say that I tested it and it works. Make sure you paste your raw data as shown above, starting in Cell A1 on Sheet1.

Book1
ABCDEFGHIJKL
1CcodeCountryCodeShortRegionZipStateDogIDDogTypeOwnerColorContinentValue
21USAUnited StatesNorthAm99999Texas4412 4916Terrier GerShepMartinez Hernandez LopezGreenAmericas30
31USAUnited StatesNorthAm77777Michigan4916 4919 4920GerShep CollieGonzalez Wilson Johnson WilliamsGreenAmericas50
41USAUnited StatesNorthAm55555Georgia5326 7060Doberman StrayBrown Jones Garcia MillerWhiteAmericas50
51USAUnited StatesNorthAm33333Montana8837 3249 8495Pom Hound GoldRetDavis Rodriguez SmithWhiteAmericas35
Sheet2



Book1
ABCDEFGHIJKL
1CcodeCountryCodeShortRegionZipStateDogIDDogTypeOwnerColorContinentValue
21USAUnited StatesNorthAm99999Texas4412TerrierMartinezGreenAmericas5
31USAUnited StatesNorthAm99999Texas4412TerrierHernandezGreenAmericas10
41USAUnited StatesNorthAm99999Texas4916GerShepLopezGreenAmericas15
51USAUnited StatesNorthAm77777Michigan4916GerShepGonzalezGreenAmericas20
61USAUnited StatesNorthAm77777Michigan4919GerShepWilsonGreenAmericas5
71USAUnited StatesNorthAm77777Michigan4920CollieJohnsonGreenAmericas10
81USAUnited StatesNorthAm77777Michigan4920CollieWilliamsGreenAmericas15
91USAUnited StatesNorthAm55555Georgia5326DobermanBrownWhiteAmericas20
101USAUnited StatesNorthAm55555Georgia5326DobermanJonesWhiteAmericas5
111USAUnited StatesNorthAm55555Georgia7060StrayGarciaWhiteAmericas10
121USAUnited StatesNorthAm55555Georgia7060StrayMillerWhiteAmericas15
131USAUnited StatesNorthAm33333Montana8837PomDavisWhiteAmericas20
141USAUnited StatesNorthAm33333Montana3249HoundRodriguezWhiteAmericas5
151USAUnited StatesNorthAm33333Montana8495GoldRetSmithWhiteAmericas10
Sheet1
 
Upvote 0
Well, its weird cause that's exactly where I pasted. Cell A1 on Sheet1 on Office 2016 but now I tried on another version of office (2010) and no error this time though but the values aren't summing up, everything else is executing perfectly. Do you think it's because of the version difference?

1617490895714.png


1617490853764.png
 

Attachments

  • 1617490874584.png
    1617490874584.png
    8.4 KB · Views: 7
Upvote 0
Yeah, your values came through funky. I had to put them in manually prior to running the code. They don't seem to be numbers i.e. if you highlight the column and look at the status bar you will see that they don't show any values...

I am using 365 if that helps at all.
 
Upvote 0
See if this gets you close to what you need. Using your raw data copied to "Sheet1", the code writes the results to "Sheet2". It is a little busy at best, but it tested successfully on your raw data.

VBA Code:
Sub Dogs()
   
    Dim arrJ, arrE, arr
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim x As Long, i As Long, y As Long, lRow As Long, G As Long, H As Long, lRow2 As Long
    Dim ct As Long, b As Long
    Dim rng As Range, rng2 As Range, rngsum As Range
    Dim str As String
   
    Application.ScreenUpdating = False
    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")
    Set rng2 = ws1.UsedRange.Offset(1, 0)
    arrJ = rng2
    arrE = rng2
    With CreateObject("Scripting.Dictionary")
    For x = LBound(arrJ) To UBound(arrJ) - 1
        If Not IsMissing(arrJ(x, 10)) Then .Item(arrJ(x, 10)) = 1
    Next
    arrJ = .Keys
    End With
    With CreateObject("Scripting.Dictionary")
    For y = LBound(arrE) To UBound(arrE) - 1
        If Not IsMissing(arrE(y, 5)) Then .Item(arrE(y, 5)) = 1
    Next
    arrE = .Keys
    End With
   
    For i = LBound(arrJ) To UBound(arrJ)
        For b = LBound(arrE) To UBound(arrE)
            ws1.Activate
            rng2.AutoFilter
            ws1.Range("J1").AutoFilter
            ws1.UsedRange.AutoFilter Field:=10, Criteria1:=arrJ(i), Operator:=xlFilterValues
            ws1.UsedRange.AutoFilter Field:=5, Criteria1:=arrE(b), Operator:=xlFilterValues
            Set rng = ActiveSheet.AutoFilter.Range
            lRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1
            rng.Offset(1, 0).Copy ws2.Range("A" & lRow)
            ws2.Activate
            lRow2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row
            If lRow2 < lRow Then GoTo skip
            Set rngsum = Range("L" & lRow & ":L" & lRow2)
            ct = WorksheetFunction.Sum(rngsum)
            For G = 7 To 9
                arr = ws2.Range("A" & lRow & ":L" & lRow2)
                With CreateObject("Scripting.Dictionary")
                    For x = LBound(arr) To UBound(arr)
                        If Not IsMissing(arr(x, G)) Then .Item(arr(x, G)) = 1
                    Next
                    arr = .Keys
                End With
                For H = LBound(arr) To UBound(arr)
                    str = str & vbNewLine & arr(H)
                Next
                str = Mid(str, 3)
                Cells(lRow, G) = str
                str = ""
            Next
            Range("L" & lRow) = ct
            Range("A" & lRow + 1 & ":A" & lRow2).EntireRow.Delete
skip:
        Next
    Next
    ws1.Range("A1:L1").Copy ws2.Range("A1")
    ws1.AutoFilter.ShowAllData
    Application.ScreenUpdating = True
   
End Sub

I hope this helps.
igold. That is a great job to be able to resolve that problem.
I noticed nobody else wanted to chime in and try and help.
That must have took some time to wright.
 
Upvote 0
I also found the code from post #2 erroring and then hanging my Excel even when using the data from the post #4 XL2BB mini-sheet.

BTW ..
@sncb I suggest that you update your Account details (click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using as the best solution often varies by version. (Don’t forget to scroll down & ‘Save’)

@igold not sure if you are aware but you are using quite an old version of XL2BB. A number of bug-fixes and enhancements have since been implemented

This is how I approached it.

VBA Code:
Sub Consolidate_Rows()
  Dim d1 As Object, d2 As Object, d3 As Object, d4 As Object
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long
  Dim s As String
 
  Set d1 = CreateObject("Scripting.Dictionary")
  Set d2 = CreateObject("Scripting.Dictionary")
  Set d3 = CreateObject("Scripting.Dictionary")
  Set d4 = CreateObject("Scripting.Dictionary")
  a = Sheets("Sheet1").Range("A1", Sheets("Sheet1").Range("L" & Rows.Count).End(xlUp)).Value
  For i = 1 To UBound(a)
    s = a(i, 5) & "|" & a(i, 10)
    If Not d1.exists(s) Then
      d1.Add s, CreateObject("Scripting.Dictionary")
      d2.Add s, CreateObject("Scripting.Dictionary")
      d3.Add s, CreateObject("Scripting.Dictionary")
    End If
    d1(s)(a(i, 7)) = 1
    d2(s)(a(i, 8)) = 1
    d3(s)(a(i, 9)) = 1
    d4(s) = d4(s) + a(i, 12)
  Next i
  ReDim b(1 To d1.Count, 1 To 12)
  For i = 1 To UBound(a)
    s = a(i, 5) & "|" & a(i, 10)
    If d1.exists(s) Then
      k = k + 1
      For j = 1 To 11
        b(k, j) = a(i, j)
      Next j
      b(k, 7) = Join(d1(s).Keys, vbLf)
      b(k, 8) = Join(d2(s).Keys, vbLf)
      b(k, 9) = Join(d3(s).Keys, vbLf)
      b(k, 12) = d4(s)
      d1.Remove s
    End If
  Next i
  With Sheets("Sheet2").Range("A1").Resize(k, 12)
    .Value = b
    .ColumnWidth = 100
    .Columns.AutoFit
  End With
End Sub
 
Upvote 0
Solution
Hi Peter,
I have updated my profile to indicate the versions I'm using actively. Thanks for the suggestions, should have done that before.

The code works flawlessly; Thank you for your effort and time towards it.

However a small bump. Some of my values have a 0 or something like .00045454 which throws up an error "runtime error 13 type mismatch". Initially I didn't know why it threw up this error but I tested my data in sets and came to the conclusion that whenever there was a 0 or very less than 0, the error showed up. Its really not a big deal as I can filter out the 0s in my main data but sometimes I need the corresponding column data in the 0 rows.

If its not a big effort to include 0s as well, that would be great. Otherwise its fine the way it is.

Thanks again and appreciate the help.
 
Upvote 0
I have updated my profile to indicate the versions I'm using actively.
Thanks for that. (y)

The code works flawlessly;

However a small bump.
Hmm, not quite flawlessly then, ;)

Some of my values have a 0 or something like .00045454 which throws up an error "runtime error 13 type mismatch". I
  1. What column(s) are those small values in?
  2. Can you confirm whether they are numerical or text in your sheet to start with?
  3. What line of code is highlighted when the error occurs and you click 'Debug'?
If you could post a small set of sample data that includes the problem (with XL2BB ) that would be helpful.
 
Upvote 0

Forum statistics

Threads
1,223,099
Messages
6,170,107
Members
452,302
Latest member
TaMere

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top