Solved

Amalgamattng (Collating Data from one Spread Sheet to another)

Posted on 2010-08-24
13
344 Views
Last Modified: 2012-05-10
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
Comment
Question by:LTAJSR
  • 7
  • 5
13 Comments
 
LVL 1

Expert Comment

by:ChrisMcIntosh
ID: 33513569
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
 

Author Comment

by:LTAJSR
ID: 33513705
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
 
LVL 17

Expert Comment

by:calacuccia
ID: 33515564
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
 

Author Comment

by:LTAJSR
ID: 33516398
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
 

Author Comment

by:LTAJSR
ID: 33516565
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
 
LVL 17

Expert Comment

by:calacuccia
ID: 33516640
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
6 Surprising Benefits of Threat Intelligence

All sorts of threat intelligence is available on the web. Intelligence you can learn from, and use to anticipate and prepare for future attacks.

 

Author Comment

by:LTAJSR
ID: 33516693
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
 
LVL 17

Expert Comment

by:calacuccia
ID: 33516751
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
 
LVL 17

Expert Comment

by:calacuccia
ID: 33516756
Lines 19 & 20 contain the Tab names.
0
 

Author Comment

by:LTAJSR
ID: 33516816
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
 
LVL 17

Accepted Solution

by:
calacuccia earned 500 total points
ID: 33516855
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
 

Author Comment

by:LTAJSR
ID: 33516980
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
 

Author Closing Comment

by:LTAJSR
ID: 33518646
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

Threat Intelligence Starter Resources

Integrating threat intelligence can be challenging, and not all companies are ready. These resources can help you build awareness and prepare for defense.

Join & Write a Comment

A2 = A1 That kind of cell reference is relative.  If you copy it from A2 to B2, then B2 will get this: B2 = B1 That's all fine and good, but if you then insert a new row above row 2, you'll find: A3 = A1 B3 = B1 This is intentional. …
Sparklines have been introduced with Excel 2010 and are a useful tool for creating small in-cell charts, used for example in dashboards. Excel 2010 offers three different types of Sparklines: Line, Column and Win/Loss. What it does not offer is a…
Viewers will learn the basics of slicers and timelines for both PivotTables and standard Excel tables in Excel 2013.
This Micro Tutorial will demonstrate how to use longer labels with horizontal bar charts instead of the vertical column chart.

746 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

10 Experts available now in Live!

Get 1:1 Help Now