Option Explicit
[color=darkblue]Sub[/color] ConcatenateData2()
Application.ScreenUpdating = [color=darkblue]False[/color] [color=green]'Not necerssary but speeds things up a bit, by turning screen updating off.[/color]
[color=darkblue]On[/color] [color=darkblue]Error[/color] [color=darkblue]GoTo[/color] TheEnd [color=green]'If anything goes wrong go to the End instead of crashing.[/color]
[color=darkblue]Dim[/color] wks1 [color=darkblue]As[/color] Worksheet, wks2 [color=darkblue]As[/color] Worksheet [color=green]' Give Abbreviations[/color]
[color=darkblue]Set[/color] wks1 = Worksheets("sheet1") [color=green]'then give all properties and method[/color]
[color=darkblue]Set[/color] wks2 = Worksheets("sheet2") [color=green]'of Object Worksheet to them via .dot thing[/color]
[color=darkblue]Dim[/color] Data1Row [color=darkblue]As[/color] [color=darkblue]Long[/color], LastData1Row [color=darkblue]As[/color] [color=darkblue]Long[/color] [color=green]'Data1 Row Number, Last Data Row in wks1. long is a Big whole Number limit (-2,147,483,648 to 2,147,483,647)[/color]
[color=darkblue]Dim[/color] OutputDataRow [color=darkblue]As[/color] [color=darkblue]Long[/color] [color=green]'Output Data Row[/color]
[color=darkblue]Let[/color] OutputDataRow = 2 [color=green]'Start puting Output data in second Row[/color]
[color=darkblue]Dim[/color] ConcanString [color=darkblue]As[/color] String [color=green]'Each line of concatenated Data 2to go in column 2 of output[/color]
[color=green]'--------Make tempory sheet with unique values from Column A (Data1)[/color]
[color=darkblue]Let[/color] Worksheets.Add(After:=wks1).Name = "Unique1" [color=green]'Add a Worksheet after the first, named Unique1 for now[/color]
[color=darkblue]Let[/color] LastData1Row = wks1.Range("A" & Rows.Count).End(xlUp).Row
wks1.Range("A1:A" & LastData1Row).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("Unique1").Range("A1"), Unique:=[color=darkblue]True[/color] [color=green]'Copies only unique A Column (Data1) to first column in Tempory made "Unique1" sheet, The important bit is Unique:=True - that only copies unique bits[/color]
[color=green]'---------------------[/color]
[color=darkblue]Dim[/color] LastUnqRow [color=darkblue]As[/color] [color=darkblue]Long[/color], UqeRow [color=darkblue]As[/color] [color=darkblue]Long[/color] [color=green]'Rows in Tempory Unique Sheet. long is a Big whole Number limit (-2,147,483,648 to 2,147,483,647)[/color]
[color=darkblue]Let[/color] LastUnqRow = Worksheets("Unique1").Cells.Find(What:="*", After:=Worksheets("Unique1").Cells(1, 1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row [color=green]'Get last Unique Row for use in next loop. method: You starta at first cell then go backwards (which effectively starts at end of sheet. This allows for different excel versions with different available Row numbers)[/color]
[color=darkblue]For[/color] UqeRow = 2 [color=darkblue]To[/color] LastUnqRow [color=green]'Take each unique Data 1[/color]
[color=darkblue]For[/color] Data1Row = 2 [color=darkblue]To[/color] LastData1Row [color=green]'go along each data row[/color]
[color=darkblue]If[/color] wks1.Cells(Data1Row, 1).Value = Worksheets("Unique1").Cells(UqeRow, 1).Value [color=darkblue]Then[/color] [color=green]'We have amatch in Data1 to a unique Data name..[/color]
[color=darkblue]Let[/color] ConcanString = ConcanString & wks1.Cells(Data1Row, 2).Value & " / " [color=green]'...So include that in the concatenated string and a " / "[/color]
wks2.Cells(OutputDataRow, 1).Value = Worksheets("Unique1").Cells(UqeRow, 1).Value
wks2.Cells(OutputDataRow, 2).Value = ConcanString
[color=darkblue]Else[/color] [color=green]'No match so do nothing[/color]
[color=darkblue]End[/color] [color=darkblue]If[/color]
[color=darkblue]Next[/color] Data1Row
[color=darkblue]Let[/color] ConcanString = "" [color=green]'After all matches are found, Empty Concanstring of last matched and concastenated Data2 and...[/color]
[color=darkblue]If[/color] wks2.Cells(OutputDataRow, 2).Value <> "" [color=darkblue]Then[/color] [color=green]'Assuming Data has been found...[/color]
[color=darkblue]Let[/color] wks2.Cells(OutputDataRow, 2).Value = Left(wks2.Cells(OutputDataRow, 2).Value, Len(wks2.Cells(OutputDataRow, 2).Value) - 3) [color=green]'Strip off last /.....[/color]
[color=darkblue]Else[/color] [color=green]' Do not do the Left Function on an empty cell![/color]
[color=darkblue]End[/color] [color=darkblue]If[/color]
[color=darkblue]Let[/color] OutputDataRow = OutputDataRow + 1 [color=green]'.... reset the next output row[/color]
[color=darkblue]Next[/color] UqeRow
wks1.AutoFilterMode = [color=darkblue]False[/color] [color=green]'Need to reset this (I think?)[/color]
Application.DisplayAlerts = [color=darkblue]False[/color] [color=green]'Prevent being asked if you really want to delete Temporary Unique sheet[/color]
Sheets("Unique1").Delete [color=green]' delete the filtered Data name sheet as you do not need it any more[/color]
Application.DisplayAlerts = [color=darkblue]True[/color]
Application.ScreenUpdating = [color=darkblue]True[/color] [color=green]'Turn screen "back on" or screen is "dead"[/color]
[color=darkblue]Exit[/color] [color=darkblue]Sub[/color] [color=green]'We stop code here assuming it worked (or at least did not crash!)[/color]
TheEnd: [color=green]'Come here if error[/color]
wks1.AutoFilterMode = [color=darkblue]False[/color]
Application.ScreenUpdating = [color=darkblue]True[/color] [color=green]'Important to do this here so if anything goes wron then the screen updating is turned back on, ohterwisee the screen is dead[/color]
MsgBox (Err.Description) [color=green]'Print out error message in Message Box[/color]
[color=darkblue]End[/color] [color=darkblue]Sub[/color]
