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

[sncb]

I have data sets that look like this below and pasted from A2 onwards with fixed no of columns but varying no of rows..

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)

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:

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

to get:

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:

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.

Ccode	Country	CodeShort	Region	Zip	State	DogID	DogType	Owner	Color	Continent	Value
1​	USA	United States	NorthAm	99999​	Texas	4412​	Terrier	Martinez	Green	Americas	5​
1​	USA	United States	NorthAm	99999​	Texas	4412​	Terrier	Hernandez	Green	Americas	10​
1​	USA	United States	NorthAm	99999​	Texas	4916​	GerShep	Lopez	Green	Americas	15​
1​	USA	United States	NorthAm	77777​	Michigan	4916​	GerShep	Gonzalez	Green	Americas	20​
1​	USA	United States	NorthAm	77777​	Michigan	4919​	GerShep	Wilson	Green	Americas	5​
1​	USA	United States	NorthAm	77777​	Michigan	4920​	Collie	Johnson	Green	Americas	10​
1​	USA	United States	NorthAm	77777​	Michigan	4920​	Collie	Williams	Green	Americas	15​
1​	USA	United States	NorthAm	55555​	Georgia	5326​	Doberman	Brown	White	Americas	20​
1​	USA	United States	NorthAm	55555​	Georgia	5326​	Doberman	Jones	White	Americas	5​
1​	USA	United States	NorthAm	55555​	Georgia	7060​	Stray	Garcia	White	Americas	10​
1​	USA	United States	NorthAm	55555​	Georgia	7060​	Stray	Miller	White	Americas	15​
1​	USA	United States	NorthAm	33333​	Montana	8837​	Pom	Davis	White	Americas	20​
1​	USA	United States	NorthAm	33333​	Montana	3249​	Hound	Rodriguez	White	Americas	5​
1​	USA	United States	NorthAm	33333​	Montana	8495​	GoldRet	Smith	White	Americas	10​

 

[igold]

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.

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.

 

[sncb]

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

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.

Thanks again for this.

 

[igold]

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
	A	B	C	D	E	F	G	H	I	J	K	L
1	Ccode	Country	CodeShort	Region	Zip	State	DogID	DogType	Owner	Color	Continent	Value
2	1	USA	United States	NorthAm	99999	Texas	4412 4916	Terrier GerShep	Martinez Hernandez Lopez	Green	Americas	30
3	1	USA	United States	NorthAm	77777	Michigan	4916 4919 4920	GerShep Collie	Gonzalez Wilson Johnson Williams	Green	Americas	50
4	1	USA	United States	NorthAm	55555	Georgia	5326 7060	Doberman Stray	Brown Jones Garcia Miller	White	Americas	50
5	1	USA	United States	NorthAm	33333	Montana	8837 3249 8495	Pom Hound GoldRet	Davis Rodriguez Smith	White	Americas	35
Sheet2

Book1
	A	B	C	D	E	F	G	H	I	J	K	L
1	Ccode	Country	CodeShort	Region	Zip	State	DogID	DogType	Owner	Color	Continent	Value
2	1	USA	United States	NorthAm	99999	Texas	4412	Terrier	Martinez	Green	Americas	5
3	1	USA	United States	NorthAm	99999	Texas	4412	Terrier	Hernandez	Green	Americas	10
4	1	USA	United States	NorthAm	99999	Texas	4916	GerShep	Lopez	Green	Americas	15
5	1	USA	United States	NorthAm	77777	Michigan	4916	GerShep	Gonzalez	Green	Americas	20
6	1	USA	United States	NorthAm	77777	Michigan	4919	GerShep	Wilson	Green	Americas	5
7	1	USA	United States	NorthAm	77777	Michigan	4920	Collie	Johnson	Green	Americas	10
8	1	USA	United States	NorthAm	77777	Michigan	4920	Collie	Williams	Green	Americas	15
9	1	USA	United States	NorthAm	55555	Georgia	5326	Doberman	Brown	White	Americas	20
10	1	USA	United States	NorthAm	55555	Georgia	5326	Doberman	Jones	White	Americas	5
11	1	USA	United States	NorthAm	55555	Georgia	7060	Stray	Garcia	White	Americas	10
12	1	USA	United States	NorthAm	55555	Georgia	7060	Stray	Miller	White	Americas	15
13	1	USA	United States	NorthAm	33333	Montana	8837	Pom	Davis	White	Americas	20
14	1	USA	United States	NorthAm	33333	Montana	3249	Hound	Rodriguez	White	Americas	5
15	1	USA	United States	NorthAm	33333	Montana	8495	GoldRet	Smith	White	Americas	10
Sheet1

 

[sncb]

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?

 

[igold]

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.

 

[nplano1]

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.

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.

 

[Peter_SSs]

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.

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

 

[sncb]

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.

 

[Peter_SSs]

I have updated my profile to indicate the versions I'm using actively.

Thanks for that.

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.