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

Use the attached sheet and then write a simple macro to pick up the column headings where COUNT is not blanks.
test-data.xls

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

Select allOpen in new window

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

Select allOpen in new window

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

Select allOpen in new window

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!