• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 396
  • Last Modified:

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
0
LTAJSR
Asked:
LTAJSR
  • 7
  • 5
1 Solution
 
ChrisMcIntoshCommented:
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.
0
 
LTAJSRAuthor Commented:
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.
0
 
calacucciaCommented:
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

0
Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

 
LTAJSRAuthor Commented:
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.


0
 
LTAJSRAuthor Commented:
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
0
 
calacucciaCommented:
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.



0
 
LTAJSRAuthor Commented:
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.


0
 
calacucciaCommented:
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

0
 
calacucciaCommented:
Lines 19 & 20 contain the Tab names.
0
 
LTAJSRAuthor Commented:
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
0
 
calacucciaCommented:
I'm about to call it a day (1 AM here).

For any error message, please indicate the exact error as popped up by Excel VBA. That will increase the chance to guide you well.

First of all, is it on the first or second line of your code?

I don't get this error here, so it probalby has something to do with the slight changes between your version and the sample.

I have also attached the working example for you to see if this one runs well.
If it does not, there might be another issue (local version, Excel version; settings ...) to be debugged.
Togethers-Test.xls
0
 
LTAJSRAuthor Commented:
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..
0
 
LTAJSRAuthor Commented:
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.  
0

Featured Post

Free Tool: Subnet Calculator

The subnet calculator helps you design networks by taking an IP address and network mask and returning information such as network, broadcast address, and host range.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

  • 7
  • 5
Tackle projects and never again get stuck behind a technical roadblock.
Join Now