Row consolidation and new worksheet creation

M

Michae1

New Member
Joined
Dec 8, 2009
Messages
6
Hi Folks,
I have a somewhat complex formatting problem that I've separated into two parts.

1. I would like to take a master list and search a column for DISTINCT values. For each distinct (value), I would like a new worksheet created with (value) as its name. Then I want to take each row that has that value and populate the appropriate worksheet.

2. After separating the data into their appropriate worksheets, I would like to consolidate multiple rows into one row given that, say, 6 fields are identical. If these rows are identical for those 6 fields but have differing values in a 7th field (column), I would like to concatenate those different values (perhaps into an array) and make one row with the array used as the value.

I'm not sure if this is possible, or if it requires Access, but any advice would be greatly appreciated.
Thanks!
 

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)
Sort by date Sort by votes
For #1) you can use this macro I have for that very task.

Code: 
Sub ParseValues()
'JBeaucaire  (11/11/2009)
'Based on column A, data is filtered to individual sheets
'Creates sheets and sorts alphabetically in workbook
Dim LR As Long, i As Long, MyArr
Dim MyCount As Long, ws As Worksheet
Application.ScreenUpdating = False

Set ws = Sheets("MasterList")
ws.Activate

Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True
Columns("AA:AA").Sort Key1:=Range("AA2"), Order1:=xlAscending, Header:=xlYes, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
MyArr = Application.WorksheetFunction.Transpose(Range("AA2:AA" & Rows.Count).SpecialCells(xlCellTypeConstants))

Range("AA:AA").Clear
Range("A1:F1").AutoFilter

For i = 1 To UBound(MyArr)
    Range("A1:F1").AutoFilter Field:=1, Criteria1:=MyArr(i)
    LR = Range("A" & Rows.Count).End(xlUp).Row
    If LR > 1 Then
        If Not Evaluate("=ISREF('" & MyArr(i) & "'!A1)") Then
            Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = MyArr(i)
        Else
            Sheets(MyArr(i)).Move After:=Sheets(Sheets.Count)
            Sheets(MyArr(i)).Cells.Clear
        End If
        ws.Activate
        Range("A1:F" & LR).Copy Sheets(MyArr(i)).Range("A1")
        Range("A1:F1").AutoFilter Field:=1
        MyCount = MyCount + Sheets(MyArr(i)).Range("A" & Rows.Count).End(xlUp).Row - 1
        Sheets(MyArr(i)).Columns.AutoFit
    End If
Next i

ActiveSheet.AutoFilterMode = False
LR = Range("A" & Rows.Count).End(xlUp).Row - 1
MsgBox "Rows with data: " & LR & vbLf & "Rows copied to other sheets: " & MyCount & vbLf & "Hope they match!!"
Application.ScreenUpdating = True
End Sub

===========
For #2, I'd need to see an exact representation of the data you want compared and the data you want merged.

Use Excel Jeanie to post up some visible examples of the data you're referring to, and perhaps a mockup of the desired results you have in mind.
 
Upvote 0
Wow, thank you so much! That worked brilliantly.
I noticed you are sorting based on data in column A, so I was wondering, to use column G, aside from replacing the A's with G's in
Code: 
Columns("A:A").AdvancedFilter
, where else would I need to adjust?

And for part 2, I've included an explanatory (I hope) screenshot of the row consolidation. Basically, there are a bunch of rows with similar data. If the only difference among rows is a change in column F or P, then we just want to combine those rows into one with the respective data in column F and/or P merged into one field.

Because entries 1 and 2 are identical except for the data in F and P, we want to combine them into one row with concatenated versions of F and P. Entry 3 has something different in G, so it remains a unique row. Entries 4 and 5 should be grouped similarly.



Once again, thank you for your help!
image.php
 
Upvote 0
The Advanced Filter is being used to create a list of unique values to make sheets from. I used column A values. You can change that to column G. But you'll also need to edit the .AutoFilter codes later to make sure they are applying the filter to the correct column.

Maybe change them all to:
Code: 
Range("G1").AutoFilter Field:=1, Criteria1:=MyArr(i)

...and

        Range("A1:AA" & LR).Copy Sheets(MyArr(i)).Range("A1")
        Range("G1").AutoFilter Field:=1

=============

For part 2, merging, try this:
Code: 
Option Explicit

Sub MergeRows()
'JBeaucaire (12/9/2009)
'Compares columns D,E,G,H,I,J,K,L,M,N,O and if same, merges rows
'Concatenates columns F and P if different/unique
Dim LR As Long, i As Long
Application.ScreenUpdating = False
LR = Range("C" & Rows.Count).End(xlUp).Row
i = 2

'Sort data so like items are adjacent
    Columns("D:R").Sort Key1:=Range("D2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

'Insert key column to determine matches
    Range("AA2:AA" & LR).FormulaR1C1 = _
            "=RC4&""-""&RC5&""-""&RC7&""-""&RC8&""-""&RC9&""-""&RC10&""-""&RC11&""-""&RC12&""-""&RC13&""-""&RC14&""-""&RC15"

'Merge like rows
    Do
        If Range("AA" & i) = Range("AA" & i + 1) Then
            If InStr(Range("F" & i), Range("F" & i + 1)) = 0 Then _
                Range("F" & i) = Range("F" & i) & "," & Range("F" & i + 1)
            If InStr(Range("P" & i), Range("P" & i + 1)) = 0 Then _
                Range("P" & i) = Range("P" & i) & "," & Range("P" & i + 1)
            Rows(i + 1).Delete xlShiftUp
        Else
            i = i + 1
            If Cells(i, "D") = "" Then Exit Do
        End If
    Loop

'Remove key column
    Columns("AA:AA").ClearContents

Application.ScreenUpdating = True
End Sub
 
Upvote 0
For some reason the merge rows macro won't run and results in an Error 400. I've looked it over and the logic seems correct, though I'm not completely sure how the Formula R1C1 is working.
I've modified the code so you see exactly the columns I am working with, and since this macro will be applied to different worksheets I've added the ActiveSheet property to control this. I can't figure out why this won't run:


Code: 
Sub MergeRows()
'JBeaucaire (12/9/2009)
'Compares columns A,B,C,D,E,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z,AA,AB,AC,AD,AE,AF and if same, merges rows
'Concatenates columns I and U if different/unique
Dim LR As Long, i As Long
Application.ScreenUpdating = False
LR = ActiveSheet.Range("G" & Rows.Count).End(xlUp).Row
i = 2

'Sort data so like items are adjacent
    Range("A1:AF6000").Sort Key1:=Range("H1"), Order1:=xlAscending, Header:= _
        xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    
'Insert key column to determine matches
    Range("AJ2:AJ" & LR).FormulaR1C1 = _
            "=RC1&""-""&RC2&""-""&RC3&""-""&RC4&""-""&RC5&""-""&RC6&""-""&RC7&""-""&RC8&""-""&RC10&""-""&RC11&""-""&RC12&""-""&RC13&""-""&RC14&""-""&RC15""-""&RC16""-""&RC17""-""&RC18""-""&RC19""-""&RC20""-""&RC22""-""&RC23""-""&RC24""-""&RC25""-""&RC26""-""&RC27""-""&RC28""-""&RC29""-""&RC30""-""&RC31""-""&RC32"

'Merge like rows
    Do
        If Range("AJ" & i) = Range("AJ" & i + 1) Then
            If InStr(Range("I" & i), Range("I" & i + 1)) = 0 Then _
                Range("I" & i) = Range("I" & i) & "," & Range("I" & i + 1)
            If InStr(Range("U" & i), Range("U" & i + 1)) = 0 Then _
                Range("U" & i) = Range("U" & i) & "," & Range("U" & i + 1)
            Rows(i + 1).Delete xlShiftUp
        Else
            i = i + 1
            If Cells(i, "G") = "" Then Exit Do
        End If
    Loop

'Remove key column
    Columns("AJ:AJ").ClearContents

Application.ScreenUpdating = True
End Sub

Thanks again for the great help.
 
Upvote 0
Michae1 said:
For some reason the merge rows macro won't run and results in an Error 400.
Click to expand...
Errors out where in the code?

Feel free to post a sheet somewhere I can take a look at it along with your edited macro installed. Or SKYPE it so me.

My SKYPE ID is devtuxx7069

Jerry Beaucaire
 
Upvote 0
Is there a way to upload files? I don't see a way to do that. We can't use Skype, but I could email you the attachment if that would work for you?
If not, I'll just go ahead and post the macros I'm using.

Code: 
Option Explicit
Sub Delete_rows()
    Application.ScreenUpdating = False
    'This Is the column that will always contain a value
    YourColumn = 7 'i.e. column B - C =3, D = 4 etc
    dlCnt = 0
    For i = 2 To 10000
        If Cells(i, YourColumn).Value = "Payer Short" Then
            Rows(i).Delete
            i = i - 1
            dlCnt = dlCnt + 1
            If dlCnt > 20000 Then Exit Sub
        ElseIf Cells(i, YourColumn).Value = "" Then
            Rows(i).Delete
            i = i - 1
            dlCnt = dlCnt + 1
            If dlCnt > 20000 Then Exit Sub
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Sub AddPayerSheets()
'(12/10/2009)
'Based on column G, data is filtered to individual sheets
'Creates sheets and sorts alphabetically in workbook
Dim LR As Long, i As Long, MyArr
Dim MyCount As Long, ws As Worksheet
Application.ScreenUpdating = False

Set ws = Sheets("Periodic Decisions by Rule")
ws.Activate

Columns("G:G").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AH1"), Unique:=True
Columns("AH:AH").Sort Key1:=Range("AH2"), Order1:=xlAscending, Header:=xlYes, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
MyArr = Application.WorksheetFunction.Transpose(Range("AH2:AH" & Rows.Count).SpecialCells(xlCellTypeConstants))

Range("AH:AH").Clear
Range("A1:AF1").AutoFilter

For i = 1 To UBound(MyArr)
    Range("A1:AF1").AutoFilter Field:=7, Criteria1:=MyArr(i)
    LR = Range("G" & Rows.Count).End(xlUp).Row
    If LR > 1 Then
        If Not Evaluate("=ISREF('" & MyArr(i) & "'!A1)") Then
            Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = MyArr(i)
        Else
            Sheets(MyArr(i)).Move After:=Sheets(Sheets.Count)
            Sheets(MyArr(i)).Cells.Clear
        End If
        ws.Activate
        Range("A1:AF" & LR).Copy Sheets(MyArr(i)).Range("A1")
        Range("A1:AF1").AutoFilter Field:=7
        MyCount = MyCount + Sheets(MyArr(i)).Range("G" & Rows.Count).End(xlUp).Row - 1
        Sheets(MyArr(i)).Columns.AutoFit
        Sheets(MyArr(i)).Rows.RowHeight = 48
    End If
Next i

ActiveSheet.AutoFilterMode = False
LR = Range("G" & Rows.Count).End(xlUp).Row - 1
MsgBox "Rows with data: " & LR & vbLf & "Rows copied to other sheets: " & MyCount & vbLf & "Hope they match!!"
Application.ScreenUpdating = True
End Sub



Sub MergeRows()
'JBeaucaire (12/9/2009)
'Compares columns A,B,C,D,E,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z,AA,AB,AC,AD,AE,AF and if same, merges rows
'Concatenates columns I and U if different/unique
Dim LR As Long, i As Long
Application.ScreenUpdating = False
LR = ActiveSheet.Range("G" & Rows.Count).End(xlUp).Row
i = 2

'Sort data so like items are adjacent
    Range("A1:AF6000").Sort Key1:=Range("H1"), Order1:=xlAscending, Header:= _
        xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    
'Insert key column to determine matches
    Range("AJ2:AJ" & LR).FormulaR1C1 = _
            "=RC1&""-""&RC2&""-""&RC3&""-""&RC4&""-""&RC5&""-""&RC6&""-""&RC7&""-""&RC8&""-""&RC10&""-""&RC11&""-""&RC12&""-""&RC13&""-""&RC14&""-""&RC15""-""&RC16""-""&RC17""-""&RC18""-""&RC19""-""&RC20""-""&RC22""-""&RC23""-""&RC24""-""&RC25""-""&RC26""-""&RC27""-""&RC28""-""&RC29""-""&RC30""-""&RC31""-""&RC32"

'Merge like rows
    Do
        If Range("AJ" & i) = Range("AJ" & i + 1) Then
            If InStr(Range("I" & i), Range("I" & i + 1)) = 0 Then _
                Range("I" & i) = Range("I" & i) & "," & Range("I" & i + 1)
            If InStr(Range("U" & i), Range("U" & i + 1)) = 0 Then _
                Range("U" & i) = Range("U" & i) & "," & Range("U" & i + 1)
            Rows(i + 1).Delete xlShiftUp
        Else
            i = i + 1
            If Cells(i, "G") = "" Then Exit Do
        End If
    Loop

'Remove key column
    Columns("AJ:AJ").ClearContents

Application.ScreenUpdating = True
End Sub
I'll also post another picture of a screenshot.



Thanks again, I really appreciate it.
 
Upvote 0
Wait, nevermind, I think it was a simple syntax error. I'm testing it to make sure, but I think your solution works perfectly, and I'll let you know when I'm able to. Thanks again.
 
Upvote 0
My pleasure...perhaps one small adjustment:
Rich (BB code): 
Sub AddPayerSheets()
'JBeaucaire   (12/10/2009)
'Based on column G, data is filtered to individual sheets
'Creates sheets and sorts alphabetically in workbook
Dim LR As Long, i As Long, MyArr

;)
 
Upvote 0
Ok.

And here's the most current version of the code so far if you or anyone else wants to see how to do this. First of all, the macro will not work correctly if there are multiple headers on a sheet, so I first run the delete rows macro to get rid of extra headers and blank rows.
Also, if you add extra rows of data by, say, appending them, the macro would sometimes not sort them correctly and not merge enough rows. If this is the case, you just have to add extra sort keys and I think this solves the problem.

Code: 
Sub Delete_rows()
    Application.ScreenUpdating = False
    'This Is the column that will always contain a value
    YourColumn = 7 'i.e. column B - C =3, D = 4 etc
    dlCnt = 0
    For i = 2 To 10000
        If Cells(i, YourColumn).Value = "Payer Short" Then
            Rows(i).Delete
            i = i - 1
            dlCnt = dlCnt + 1
            If dlCnt > 20000 Then Exit Sub
        ElseIf Cells(i, YourColumn).Value = "" Then
            Rows(i).Delete
            i = i - 1
            dlCnt = dlCnt + 1
            If dlCnt > 20000 Then Exit Sub
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Sub AddPayerSheets()
'JBeaucaire(12/10/2009)
'Based on column G, data is filtered to individual sheets
'Creates sheets and sorts alphabetically in workbook
Dim LR As Long, i As Long, MyArr
Dim MyCount As Long, ws As Worksheet
Application.ScreenUpdating = False

Set ws = Sheets("Periodic Decisions by Rule")
ws.Activate

Columns("G:G").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AH1"), Unique:=True
Columns("AH:AH").Sort Key1:=Range("AH2"), Order1:=xlAscending, Header:=xlYes, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
MyArr = Application.WorksheetFunction.Transpose(Range("AH2:AH" & Rows.Count).SpecialCells(xlCellTypeConstants))

Range("AH:AH").Clear
Range("A1:AF1").AutoFilter

For i = 1 To UBound(MyArr)
    Range("A1:AF1").AutoFilter Field:=7, Criteria1:=MyArr(i)
    LR = Range("G" & Rows.Count).End(xlUp).Row
    If LR > 1 Then
        If Not Evaluate("=ISREF('" & MyArr(i) & "'!A1)") Then
            Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = MyArr(i)
        Else
            Sheets(MyArr(i)).Move After:=Sheets(Sheets.Count)
            Sheets(MyArr(i)).Cells.Clear
        End If
        ws.Activate
        Range("A1:AF" & LR).Copy Sheets(MyArr(i)).Range("A1")
        Range("A1:AF1").AutoFilter Field:=7
        MyCount = MyCount + Sheets(MyArr(i)).Range("G" & Rows.Count).End(xlUp).Row - 1
        Sheets(MyArr(i)).Columns.AutoFit
        Sheets(MyArr(i)).Rows.RowHeight = 48
    End If
Next i

ActiveSheet.AutoFilterMode = False
LR = Range("G" & Rows.Count).End(xlUp).Row - 1
MsgBox "Rows with data: " & LR & vbLf & "Rows copied to other sheets: " & MyCount & vbLf & "Hope they match!!"
Application.ScreenUpdating = True
End Sub



Sub MergeRows()
'JBeaucaire (12/9/2009)
'Compares columns A,B,C,D,E,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z,AA,AB,AC,AD,AE,AF and if same, merges rows
'Concatenates columns I and U if different/unique
Dim LR As Long, i As Long
Application.ScreenUpdating = False
LR = ActiveSheet.Range("G" & Rows.Count).End(xlUp).Row
i = 2

'Sort data so like items are adjacent
    Range("A1:AF6000").Sort Key1:=Range("H1"), Order1:=xlAscending, Key2:=Range("L1"), Order2:=xlAscending, Key3:=Range("I1"), Order3:=xlAscending, Header:= _
        xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    
'Insert key column to determine matches

    Range("AJ2:AJ" & LR).FormulaR1C1 = _
            "=RC1&""-""&RC2&""-""&RC3&""-""&RC4&""-""&RC5&""-""&RC6&""-""&RC7&""-""&RC8&""-""&RC10&""-""&RC11&""-""&RC12&""-""&RC13&""-""&RC14&""-""&RC15&""-""&RC16&""-""&RC17&""-""&RC18&""-""&RC19&""-""&RC20&""-""&RC22&""-""&RC23&""-""&RC24&""-""&RC25&""-""&RC26&""-""&RC27&""-""&RC28&""-""&RC29&""-""&RC30&""-""&RC31&""-""&RC32"


'Merge like rows
    Do
        If Range("AJ" & i) = Range("AJ" & i + 1) Then
            If InStr(Range("I" & i), Range("I" & i + 1)) = 0 Then _
                Range("I" & i) = Range("I" & i) & "," & Range("I" & i + 1)
            If InStr(Range("U" & i), Range("U" & i + 1)) = 0 Then _
                Range("U" & i) = Range("U" & i) & "," & Range("U" & i + 1)
            Rows(i + 1).Delete xlShiftUp
        Else
            i = i + 1
            If Cells(i, "G") = "" Then Exit Do
        End If
    Loop

'Remove key column
    Columns("AJ:AJ").ClearContents

Application.ScreenUpdating = True
End Sub

Jerry, I want to thank you again for all your help. Much appreciated. :)
 
Upvote 0
You must log in or register to reply here.

Similar threads

N
  • Solved
Help with formula consolidating Data
2
Replies
12
Views
414
Fluff
Fluff
S
  • Question Question
Consolidate or Similar, Only with Formula Reference?
Replies
0
Views
261
Scotster
S
J
  • Solved
Speeding up VBA
Replies
9
Views
154
jvoss
J
T
  • Solved
How can I filter duplicates from a worksheet column out of a data validation list drop-down box?
Replies
5
Views
77
Peter_SSs
Peter_SSs
H
  • Question Question
Need Help Consolidating/Condensing rows together if similar information
Replies
2
Views
204
Handienak
H

Forum statistics

Threads
1,223,907
Messages
6,175,301
Members
452,633
Latest member
DougMo

Share this page

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