asked on

Amalgamattng (Collating Data from one Spread Sheet to another)

Hello – is there a way to automatically amalgamate all the same items in Column F and then include all items in their respective rows and insert into a new worksheet (ie. Together)?
For example – how can excel automatically pull together all “apples” in Column F, then insert in the new tab called together presenting data in the rows together in 1 row. I have indicated how I would like to have the data presented in row 4 by indicating & (and), + (sum), top sum(Look at similar items in column R and insert the one with the great IN sum in Column AF)
I have attached a file. The “list” tab is where the data is and the “together” tab is where amalgamated data needs to be inserted. This needs to be done for all items in Column F. If a row in column F is blank, the data should not be transferred to the “together” tab.

Togethers-Test.xls

ChrisMcIntosh

I think you just want to sort the data by column F. You can select all data from List copy and paste in together. Click data at the very top in excel 2003. Then click sort. Then specify column F. If you need a macro to do that let me know.

LTAJSR

ASKER

Please read my question very carefully and open attachment. If you look at the "together" tab that is what the output should look like for each item in Column F in the "List"Tab. I need a macro to automatically pick up all items in Column F (in the List Tab) and spit them out in the "together" Tab starting at row 6 (in the format presented). Please note each column requires different taks when amalgamatting (ie. &, +, summing NI and inserting the word with the biggest number). I have provided an example in the attachment on row 6 of how output needs to be...but this needs to be automatted for all the items in Column F (except 0, Blanks) in the "list tab"

Let me know if you can help.

calacuccia

I hope this is working as well as it does for me :-)

Great fun, found some new methods to get Unique Records.

Sub AmalgamattingStuff()
Dim fSh As Worksheet
Dim sSh As Worksheet
Dim mB As Workbook
Dim lastRow As Long
Dim mF As AutoFilter
Dim Rng As Range
Dim c As Range
Dim Data As Variant
Dim DSO As Object
Dim I As Long, J As Long, K As Long
Dim Key As Variant
Dim Keys As Variant
Dim AFValue As Long
Dim AFRow As Long
  
'Declare Variables
Set mB = ThisWorkbook
Set fSh = mB.Worksheets("List")
fSh.Copy After:=fSh
Set sSh = ActiveSheet
sSh.AutoFilterMode = False
sSh.Range("A6:AW" & sSh.UsedRange.SpecialCells(xlCellTypeLastCell).Row).ClearContents
sSh.Name = "My_Together"
'Set sSh = mB.Worksheets("Together")
Set mF = fSh.AutoFilter
'Look for Unique records except 0 or blank
lastRow = fSh.UsedRange.SpecialCells(xlCellTypeLastCell).Row
Set Rng = fSh.Range("F6:F" & lastRow)
Data = Rng.Value

Set DSO = CreateObject("Scripting.Dictionary")
DSO.CompareMode = vbTextCompare
      
For I = 1 To UBound(Data, 1)
    Key = Data(I, 1)
    If Key <> "" And Key <> "0" Then
        If Not DSO.Exists(Key) Then DSO.Add Key, 1
    End If
Next I
Keys = DSO.Keys
'Loop through the different selected records and create the Amalgamatting
J = 6
For I = 0 To UBound(Keys)
    fSh.UsedRange.AutoFilter field:=6, Criteria1:=Keys(I)
    sSh.Cells(J, 6) = Keys(I)
    AFRow = 0
    AFValue = 0
    For Each c In mF.Range.Columns(1).SpecialCells(xlCellTypeVisible)
        If fSh.Cells(c.Row, 6) = "Together" Then GoTo Nextc
        'All the & columns
        For K = 7 To 12
            If sSh.Cells(J, K) = "" Then
                sSh.Cells(J, K) = fSh.Cells(c.Row, K)
            Else
                sSh.Cells(J, K) = sSh.Cells(J, K) & ", " & fSh.Cells(c.Row, K)
            End If
        Next K
        For K = 15 To 16
            If sSh.Cells(J, K) = "" Then
                sSh.Cells(J, K) = fSh.Cells(c.Row, K)
            Else
                sSh.Cells(J, K) = sSh.Cells(J, K) & ", " & fSh.Cells(c.Row, K)
            End If
        Next K
        For K = 25 To 27
            If sSh.Cells(J, K) = "" Then
                sSh.Cells(J, K) = fSh.Cells(c.Row, K)
            Else
                sSh.Cells(J, K) = sSh.Cells(J, K) & ", " & fSh.Cells(c.Row, K)
            End If
        Next K
        For K = 33 To 34
            If sSh.Cells(J, K) = "" Then
                sSh.Cells(J, K) = fSh.Cells(c.Row, K)
            Else
                sSh.Cells(J, K) = sSh.Cells(J, K) & ", " & fSh.Cells(c.Row, K)
            End If
        Next K
        'All the + columns
        For K = 13 To 14
            If sSh.Cells(J, K) = "" Then
                sSh.Cells(J, K).Value = fSh.Cells(c.Row, K).Value
            Else
                sSh.Cells(J, K).Value = sSh.Cells(J, K).Value + fSh.Cells(c.Row, K).Value
            End If
        Next K
        For K = 28 To 31
            If sSh.Cells(J, K) = "" Then
                sSh.Cells(J, K).Value = fSh.Cells(c.Row, K).Value
            ElseIf IsNumeric(fSh.Cells(c.Row, K)) = True Then
                sSh.Cells(J, K).Value = sSh.Cells(J, K).Value + fSh.Cells(c.Row, K).Value
            End If
        Next K
        For K = 35 To 35
            If sSh.Cells(J, K) = "" Then
                sSh.Cells(J, K).Value = fSh.Cells(c.Row, K).Value
            Else
                sSh.Cells(J, K).Value = sSh.Cells(J, K).Value + fSh.Cells(c.Row, K).Value
            End If
        Next K
        '32 Default to GD
        K = 32
        sSh.Cells(J, K) = "GC"
        'The specials columns first test the value in Column AF
        If AFValue = 0 Then
            AFValue = fSh.Cells(c.Row, 32)
            AFRow = c.Row
        ElseIf fSh.Cells(c.Row, 32) > AFValue Then
            AFValue = fSh.Cells(c.Row, 32)
            AFRow = c.Row
        End If
Nextc:
    Next c
    For K = 18 To 24
        sSh.Cells(J, K) = fSh.Cells(AFRow, K)
    Next K
    AFValue = 0
    AFRow = 0
    J = J + 1
Next I
Set DSO = Nothing

'mF.Filters(6).Criteria1 = Keys(I)
End Sub

Sub ListUniques()

  Dim Data As Variant
  Dim DSO As Object
  Dim I As Long
  Dim Key As Variant
  Dim Keys As Variant
  Dim Rng As Range
  Dim RngEnd As Range
  
    Set Rng = Range("A2")
    Set RngEnd = Cells(Rows.Count, Rng.Column).End(xlUp)
    Set Rng = IIf(RngEnd.Row < Rng.Row, Rng, Range(Rng, RngEnd))
    
    Data = Rng.Value
     
      Set DSO = CreateObject("Scripting.Dictionary")
      DSO.CompareMode = vbTextCompare
      
      For I = 1 To UBound(Data, 1)
        Key = Data(I, 1)
        If Not DSO.Exists(Key) Then DSO.Add Key, 1
      Next I
      
      Keys = DSO.Keys
      
      For I = 0 To UBound(Keys)
        Cells(2, "B").Offset(I, 0) = Keys(I)
      Next I

    Set DSO = Nothing
    
End Sub

Open in new window

LTAJSR

ASKER

You are awesome. I am glad it worked. Great Job!!! I have an issue transferring this to my real file. The Tabs real names are:

Master Plan - Initiatives (Instead of List)
GC (Instead of My Together)

Also if I have a Password to protect the sheet - will this macro still work?

Currently when I try to apply this to my actual file, I get an error message saying:

Can't execute code in break. Are you able to help with this? Happy to offer more points.

LTAJSR

ASKER

My headings are also different from actual ...are you able to tell me if this impacts my copying the macro over? If so, can you guide me how to change the Macro so I can match my headings?

Thanks

calacuccia

Hi

If the position of your headings is not identical, it will need some twisting around.
If only the Text is different is does not influence at all.

I'll wait for your reply as to how the headings are different to guide you.

Regarding the Tab names, you'll need to change it in the beginning

Line 19 Set fSh = mB.Worksheets("List") --> Change "List" to your reel tabname

Line 24 sSh.Name = "My_Together" --> I actually add a new Worksheet (to preserve formatting) and name it "My_Together"

For your Code Break message, it's because somewhere a macro is in progress but set on Break.
http://support.microsoft.com/kb/177828

Finally, if the sheet to be written to is protected, the code will not work. The Target sheet needs to be unprotected. Note that I copy the Source sheet to create a new sheet, and the protection will be copies as well.... But there are certainly turnarounds possible.

LTAJSR

ASKER

Hi

yes - the position of your headings are identical, only the text is different.

Line 24 sSh.Name = "My_Together" --> I actually add a new Worksheet (to preserve formatting) and name it "My_Together" - I already have a worksheet that has the exact formatting - is it possible to have the macro run into the worksheet called "Together" since I will be running this macro monthly to get updates and don't want to have to keep deleting tabs. Is there an issue of running the macro over and over on the same worksheet to get updates.

calacuccia

Yes, it's perfectly possible.

See alternative below.

Sheet names to be customized by you on lines 18 & 19.

If the second sheet is not protected but the' first is, it should work, but I'm not sure, as I use the Autofilter on the first sheet to quickly select the right data.

Sub AmalgamattingStuff()
Dim fSh As Worksheet
Dim sSh As Worksheet
Dim mB As Workbook
Dim lastRow As Long
Dim mF As AutoFilter
Dim Rng As Range
Dim c As Range
Dim Data As Variant
Dim DSO As Object
Dim I As Long, J As Long, K As Long
Dim Key As Variant
Dim Keys As Variant
Dim AFValue As Long
Dim AFRow As Long
  
'Declare Variables
Set mB = ThisWorkbook
Set fSh = mB.Worksheets("List")
Set sSh = mB.Worksheets("OtherName")
sSh.AutoFilterMode = False
sSh.Range("A6:AW" & sSh.UsedRange.SpecialCells(xlCellTypeLastCell).Row).ClearContents
Set mF = fSh.AutoFilter
'Look for Unique records except 0 or blank
lastRow = fSh.UsedRange.SpecialCells(xlCellTypeLastCell).Row
Set Rng = fSh.Range("F6:F" & lastRow)
Data = Rng.Value

Set DSO = CreateObject("Scripting.Dictionary")
DSO.CompareMode = vbTextCompare
      
For I = 1 To UBound(Data, 1)
    Key = Data(I, 1)
    If Key <> "" And Key <> "0" Then
        If Not DSO.Exists(Key) Then DSO.Add Key, 1
    End If
Next I
Keys = DSO.Keys
'Loop through the different selected records and create the Amalgamatting
J = 6
For I = 0 To UBound(Keys)
    fSh.UsedRange.AutoFilter field:=6, Criteria1:=Keys(I)
    sSh.Cells(J, 6) = Keys(I)
    AFRow = 0
    AFValue = 0
    For Each c In mF.Range.Columns(1).SpecialCells(xlCellTypeVisible)
        If fSh.Cells(c.Row, 6) = "Together" Then GoTo Nextc
        'All the & columns
        For K = 7 To 12
            If sSh.Cells(J, K) = "" Then
                sSh.Cells(J, K) = fSh.Cells(c.Row, K)
            Else
                sSh.Cells(J, K) = sSh.Cells(J, K) & ", " & fSh.Cells(c.Row, K)
            End If
        Next K
        For K = 15 To 16
            If sSh.Cells(J, K) = "" Then
                sSh.Cells(J, K) = fSh.Cells(c.Row, K)
            Else
                sSh.Cells(J, K) = sSh.Cells(J, K) & ", " & fSh.Cells(c.Row, K)
            End If
        Next K
        For K = 25 To 27
            If sSh.Cells(J, K) = "" Then
                sSh.Cells(J, K) = fSh.Cells(c.Row, K)
            Else
                sSh.Cells(J, K) = sSh.Cells(J, K) & ", " & fSh.Cells(c.Row, K)
            End If
        Next K
        For K = 33 To 34
            If sSh.Cells(J, K) = "" Then
                sSh.Cells(J, K) = fSh.Cells(c.Row, K)
            Else
                sSh.Cells(J, K) = sSh.Cells(J, K) & ", " & fSh.Cells(c.Row, K)
            End If
        Next K
        'All the + columns
        For K = 13 To 14
            If sSh.Cells(J, K) = "" Then
                sSh.Cells(J, K).Value = fSh.Cells(c.Row, K).Value
            Else
                sSh.Cells(J, K).Value = sSh.Cells(J, K).Value + fSh.Cells(c.Row, K).Value
            End If
        Next K
        For K = 28 To 31
            If sSh.Cells(J, K) = "" Then
                sSh.Cells(J, K).Value = fSh.Cells(c.Row, K).Value
            ElseIf IsNumeric(fSh.Cells(c.Row, K)) = True Then
                sSh.Cells(J, K).Value = sSh.Cells(J, K).Value + fSh.Cells(c.Row, K).Value
            End If
        Next K
        For K = 35 To 35
            If sSh.Cells(J, K) = "" Then
                sSh.Cells(J, K).Value = fSh.Cells(c.Row, K).Value
            Else
                sSh.Cells(J, K).Value = sSh.Cells(J, K).Value + fSh.Cells(c.Row, K).Value
            End If
        Next K
        '32 Default to GD
        K = 32
        sSh.Cells(J, K) = "GC"
        'The specials columns first test the value in Column AF
        If AFValue = 0 Then
            AFValue = fSh.Cells(c.Row, 32)
            AFRow = c.Row
        ElseIf fSh.Cells(c.Row, 32) > AFValue Then
            AFValue = fSh.Cells(c.Row, 32)
            AFRow = c.Row
        End If
Nextc:
    Next c
    For K = 18 To 24
        sSh.Cells(J, K) = fSh.Cells(AFRow, K)
    Next K
    AFValue = 0
    AFRow = 0
    J = J + 1
Next I
Set DSO = Nothing

'mF.Filters(6).Criteria1 = Keys(I)
End Sub

Sub ListUniques()

  Dim Data As Variant
  Dim DSO As Object
  Dim I As Long
  Dim Key As Variant
  Dim Keys As Variant
  Dim Rng As Range
  Dim RngEnd As Range
  
    Set Rng = Range("A2")
    Set RngEnd = Cells(Rows.Count, Rng.Column).End(xlUp)
    Set Rng = IIf(RngEnd.Row < Rng.Row, Rng, Range(Rng, RngEnd))
    
    Data = Rng.Value
     
      Set DSO = CreateObject("Scripting.Dictionary")
      DSO.CompareMode = vbTextCompare
      
      For I = 1 To UBound(Data, 1)
        Key = Data(I, 1)
        If Not DSO.Exists(Key) Then DSO.Add Key, 1
      Next I
      
      Keys = DSO.Keys
      
      For I = 0 To UBound(Keys)
        Cells(2, "B").Offset(I, 0) = Keys(I)
      Next I

    Set DSO = Nothing
    
End Sub

Open in new window

calacuccia

Lines 19 & 20 contain the Tab names.

LTAJSR

ASKER

Thank you again. I made the change but i get a prompt to debug the following:

mF.Range.Columns(1).SpecialCells(xlCellTypeVisible)
If fSh.Cells(c.Row, 6) = "Together" Then GoTo Nextc

Can you guide me what to do/Check

ASKER CERTIFIED SOLUTION

calacuccia

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

LTAJSR

ASKER

ok - thank you for your help. I want to give you your points and extra. I will figure out how to do this. In the meantime, I will continue to work throught this..

LTAJSR

ASKER

Thank you so much for figuring this problem out so quickly. I would like to reward you more points but it doesn't look like the system allows me to.