Solved

Amalgamattng (Collating Data from one Spread Sheet to another)

Posted on 2010-08-24
13
391 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 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
Online Training Solution

Drastically shorten your training time with WalkMe's advanced online training solution that Guides your trainees to action. Forget about retraining and skyrocket knowledge retention rates.

 

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
 

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

On Demand Webinar: Networking for the Cloud Era

Did you know SD-WANs can improve network connectivity? Check out this webinar to learn how an SD-WAN simplified, one-click tool can help you migrate and manage data in the cloud.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This article describes a serious pitfall that can happen when deleting shapes using VBA.
This article describes how to use a set of graphical playing cards to create a Draw Poker game in Excel or VB6.
This Micro Tutorial demonstrates how to create Excel charts: column, area, line, bar, and scatter charts. Formatting tips are provided as well.
This Micro Tutorial will demonstrate the scrolling table in Microsoft Excel using the INDEX function.

627 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