?
Solved

Excel script to combine data from multiple cells on sheet1 to one cell on sheet2

Posted on 2010-01-04
6
Medium Priority
?
339 Views
Last Modified: 2012-05-08
I have an excel worksheet where I have the following colum headings City, Zip, Mfg, Code, Model and Serial Number.  I am concatenating the data from Code, Model and Serial # into column H.  What I need is a script or something to go through the worksheet and find all records that have the same city and zip and combine all the respective data in column H for those records in the same cell on a Results worksheet. For example:

Source Page:
Columbus, 43215, ...code model serial 1
Columbus, 43215, ...code model serial 2
Columbus, 43215, ...code model serial 3

Results Page:
Columbus, 43215, code model serial 1
                              code model serial 2
                              code model serial 3

Also need it to move all the unique records from the source page to the results page.  
test-data.xls
0
Comment
Question by:ClearBlueTechnologies
6 Comments
 
LVL 38

Accepted Solution

by:
Shift-3 earned 2000 total points
ID: 26171937
Paste the script below into a text file with a .vbs extension.  Customize the value of the strFile variable on line 1 with the location of the Excel file to open.  Running the script will add a Results tab to the file containing the information you specified.

Back up the file beforehand and test carefully before running this on a production system.


strFile = "c:\test-data.xls"
 
Set objResults = CreateObject("Scripting.Dictionary")
objResults.CompareMode = VbTextCompare
 
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = False
objExcel.DisplayAlerts = False
 
Set objWorkbook = objExcel.Workbooks.Open(strFile)
Set objSourceSheet = objExcel.ActiveWorkbook.Worksheets(1)
 
intRow = 2
 
Do While objSourceSheet.Cells(intRow, 1).Value <> ""
    strCity = objSourceSheet.Cells(intRow, 1).Value
    strZip = objSourceSheet.Cells(intRow, 2).Value
    strMerged = objSourceSheet.Cells(intRow, 8).Value
    strCityZip = strCity & "," & strZip
    
    If Not objResults.Exists(strCityZip) Then
        objResults.Add strCityZip, strMerged
    Else
        objResults.Item(strCityZip) = objResults.Item(strCityZip)_
            & vbLf & strMerged
    End If
    
    intRow = intRow + 1
Loop
 
Set objResultsSheet = objExcel.ActiveWorkbook.Worksheets.Add
objResultsSheet.Name = "Results"
objResultsSheet.Cells(1, 1).Value = "City"
objResultsSheet.Cells(1, 2).Value = "Zip"
objResultsSheet.Cells(1, 3).Value = "Merged"
 
intRow = 2
 
For Each strCityZip In objResults.Keys
    arrCityZip = Split(strCityZip, ",")
    objResultsSheet.Cells(intRow, 1).Value = arrCityZip(0)
    objResultsSheet.Cells(intRow, 2).Value = arrCityZip(1)
    objResultsSheet.Cells(intRow, 3).Value = objResults.Item(strCityZip)
    
    intRow = intRow + 1
Next
 
objExcel.ActiveWorkbook.Save
objExcel.Quit

Open in new window

0
 
LVL 13

Expert Comment

by:sameer2010
ID: 26171963
Use the attached sheet and then write a simple macro to pick up the column headings where COUNT is not blanks.
test-data.xls
0
 
LVL 12

Expert Comment

by:sstampf
ID: 26172091
You can insert the code below into your file. When you need the result just insert a new sheet (or activate the sheet where you want your result to appear) and then run this macro. Let me know if you have any questions/concerns.
Sub EESample()
    Dim shtTarget As Worksheet
    Set shtTarget = ActiveSheet
    Dim i As Long
    i = 2
    Sheets("Source").Select
    Range("A1").Select
    Selection.CurrentRegion.Select
    Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Do While Range("B" & i).Value <> ""
    If Range("B" & i).Value = Range("B" & (i - 1)).Value Then
        Range("A" & i & ":B" & i).ClearContents
    End If
    Range("H" & i).Value = Range("D" & i).Value & " " & Range("E" & i).Value & " " & Range("F" & i).Value
    i = i + 1
    Loop
    Cells.Select
    Selection.Copy
    shtTarget.Select
    Range("A1").Select
    ActiveSheet.Paste
End Sub

Open in new window

0
Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
LVL 12

Expert Comment

by:sstampf
ID: 26172432
Sorry, ignore the code I have provided above and use this code instead. Just insert a new sheet and run this code or activate the sheet where you want the result to appear and then run this code.
Sub EESample1()
    Dim shtTarget As Worksheet
    Set shtTarget = ActiveSheet
    Dim i As Long
    i = 2
    Sheets("Source").Select
    Range("A1").Select
    Selection.CurrentRegion.Select
    Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
        Cells.Select
    Selection.Copy
    shtTarget.Select
    Range("A1").Select
    ActiveSheet.Paste
    Do While Range("B" & i).Value <> ""
    For j = 2 To i - 1
    If Range("B" & i).Value = Range("B" & j).Value Then
        Range("A" & i & ":B" & i).ClearContents
        Exit For
    End If
    Next j
    Range("H" & i).Value = Range("D" & i).Value & " " & Range("E" & i).Value & " " & Range("F" & i).Value
    i = i + 1
    Loop
End Sub

Open in new window

0
 
LVL 1

Author Comment

by:ClearBlueTechnologies
ID: 26182251
Thanks for all the input - I've taken the modified the first vbs script to fit our needs and it works on a small test data sample. The new excel data layout is:

Source
[Name 1] [Address 1] [City] [Zip] [A] [B] [C] [D]
[Name 1] [Address 1] [City] [Zip] [E] [F] [G] [H]
[Name 2] [Address 2] [City] [Zip] [w] [X] [Y] [Z]

becomes

Result:
[Name1] [Address1] [City] [Zip] [ABCD, EFGH]
[Name2] [Address2] [City] [Zip] [WXYZ]

This works perfectly on small subset of our data (random selection of 10 entries), but when it's run against the full data set (approximately 3500 entries) I get the following error:

Windows Script Host
Line 24 Char 2
Error: Object required: objSourceSheet.Cells
Code: 800A01A8
Source: Microsoft VBScript runtime error

Is there something in the larger dataset that would be causing the issue? I've check through the data and everything looks normal... please advise - thanks!
strFile = "d:\testdata.xls" 
  
Set objResults = CreateObject("Scripting.Dictionary") 
objResults.CompareMode = VbTextCompare 
  
Set objExcel = CreateObject("Excel.Application") 
objExcel.Visible = False 
objExcel.DisplayAlerts = False 
  
Set objWorkbook = objExcel.Workbooks.Open(strFile) 
Set objSourceSheet = objExcel.ActiveWorkbook.Worksheets(1) 
  
intRow = 1 
  
Do While objSourceSheet.Cells(intRow, 1).Value <> "" 

   	strName = objSourceSheet.Cells(intRow,1).Value
	strAddress = objSourceSheet.Cells(intRow,2).Value
	strCity = objSourceSheet.Cells(intRow,3).Value 
   	strZip = objSourceSheet.Cells(intRow,4).Value

	strMfg = objSourceSheet.Cells(intRow,5).Value
	strCode = objSourceSheet.Cells(intRow,6).Value
	strModel = objSourceSheet.Cells(intRow,7).Value
	strSerial = objSourceSheet.Cells(intRow,8).Value
	 
    	strNameCityZip = strName & ";" & strAddress & ";" & strCity & ";" & strZip
	strMerged = strMfg & " - " & strCode & " - " & strModel & " - " & strSerial
     
    If Not objResults.Exists(strNameCityZip) Then 
        objResults.Add strNameCityZip, strMerged 
    Else 
        objResults.Item(strNameCityZip) = objResults.Item(strNameCityZip)_ 
            & vbLf & strMerged 
    End If 
     
    intRow = intRow + 1 
Loop 
  
Set objResultsSheet = objExcel.ActiveWorkbook.Worksheets.Add 
objResultsSheet.Name = "Results" 

intRow = 1 
  
For Each strNameCityZip In objResults.Keys 

   	arrNameCityZip = Split(strNameCityZip, ";") 

   	objResultsSheet.Cells(intRow, 1).Value = arrNameCityZip(0) 
   	objResultsSheet.Cells(intRow, 2).Value = arrNameCityZip(1) 
	objResultsSheet.Cells(intRow, 3).Value = arrNameCityZip(2)
	objResultsSheet.Cells(intRow, 4).Value = arrNameCityZip(3)
   	objResultsSheet.Cells(intRow, 5).Value = objResults.Item(strNameCityZip) 
     
    intRow = intRow + 1 
Next 
  
objExcel.ActiveWorkbook.Save 
objExcel.Quit

Open in new window

0
 
LVL 1

Author Comment

by:ClearBlueTechnologies
ID: 26293493
Figured out the error - turns out the script take a huge amount of time to run on the larger data sets, added a few output commands to tell me where in the script it was and made sure the excel file wasn't opened before the script finished. If the excel file was opened before the script fully completed the error occurred. Thanks for all the input!
0

Featured Post

Visualize your virtual and backup environments

Create well-organized and polished visualizations of your virtual and backup environments when planning VMware vSphere, Microsoft Hyper-V or Veeam deployments. It helps you to gain better visibility and valuable business insights.

Question has a verified solution.

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

Are you looking for the options available for exporting EDB files to PST? You may be confused as they are different in different Exchange versions. Here, I will discuss some options available.
Eseutil Hard Recovery is part of exchange tool and ensures Exchange mailbox data recovery when mailbox gets corrupt due to some problem on Exchange server.
This video shows how to quickly and easily deploy an email signature for all users in Office 365 and prevent it from being added to replies and forwards. (the resulting signature is applied on the server level in Exchange Online) The email signat…
There are cases when e.g. an IT administrator wants to have full access and view into selected mailboxes on Exchange server, directly from his own email account in Outlook or Outlook Web Access. This proves useful when for example administrator want…
Suggested Courses

807 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