I have multiple rows (1100+) with the following format VIN1 Model1 Campaign1

VIN1 Model1 Campaign1 Campain2

VIN1 Model1 Campaign3Should be:

VIN1 Model1 Campaign1 Campaign2 Campaign3

The below code I have gets me most of what I want except it duplicates the first data row's Campaign1 # all the way through. I then have to do a replace to get rid of the duplicate first Campaign1 #.

CODE:

Sub Scrub()

Dim DataRange As Range

Dim DataSheet As String, SummarySheet As String

Dim Digits As StringApplication.ScreenUpdating = False

Set DataRange = Range("A2:C" & Range("A65536").End(xlUp).Row)

DataSheet = ActiveSheet.Name

Sheets.Add before:=Sheets(DataSheet)

SummarySheet = ActiveSheet.Name

Sheets(DataSheet).Range("A1:B" & DataRange.Rows.Count).Copy _

Destination:=Range("A1")

Sheets(SummarySheet).Range("A1:B" & DataRange.Rows.Count). _

AdvancedFilter Action:=xlFilterCopy, _

CopyToRange:=Range("C1"), Unique:=True

Sheets(SummarySheet).Columns("A:B").Delete Shift:=xlToLeft

For Each c In Sheets(SummarySheet).Range("A1:A" & _

Sheets(SummarySheet).Range("A65536").End(xlUp).Row)

DataRange.AutoFilter Field:=1, Criteria1:=c.Value

Digits = ""

For Each cell In DataRange. _

Columns("C:C").SpecialCells(xlCellTypeVisible)

If cell.Value <> "Campaign #" Then

Digits = Digits & cell.Value & " "

End If

Next cell

Digits = Left(Digits, Len(Digits) - 1)

c.Offset(0, 2).Value = Digits

Next c

DataRange.AutoFilter

Sheets(SummarySheet).Range("C1").Value = "Campaign #"

Range("A1:C1").Select

Selection.Font.Bold = True

Sheets(SummarySheet).Cells.EntireColumn.AutoFit

Application.ScreenUpdating = True

End SubI'd like to be able to remove the need to manually do the replace. I know there have been several variations on this topic which have helped fine tune me to this point but now I'm frustrated.

Thanks in advance.

First, a posting tip: When posting code, you should use the "pre tags" so the code will be indented and formatted just like I assume it is in the VBA editor. That would make it a lot easier to follow.

As to your question, you posted example data that looks like this:

VIN1 Model1 Campaign1

VIN1 Model1 Campaign1 Campain2

VIN1 Model1 Campaign3I'll assume that

Campain2is a typo and should beCampaign2.The problem I'm having is that in your code, you use lines like:

If cell.Value <> "Campaign #" ThenI would like to be able to duplicate your results, but none of the example data contain the string "Campaign #" so I can't.

I don't want to guess at what your actual data looks like and then build code around an incorrect assumption. If you could post some example data for which the code will actually produce the results that you are seeing, that would help.

Keep in mind that you are much closer to the code than we are and we need to figure out what it is doing/not doing before we can offer suggestions on how to fix it. Having data that produces the results that you are seeing would be beneficial.

apologies on the format for data...1st column is VIN (JN1AZ34D93T114559), 2nd model (2003 350Z En), 3rd is Campaign # (R0505 PM952) The last two VINs I duplicated just so you can get the idea.

Some data below. I also resubmitted with pre tags as you requested. you're right, much better format.

VIN # Model Campaign #

1N4BL21E77C188343 2007 ALTIMA P7221

3N1AB61E79L615448 2009 SENTRA PM952

JN1AZ34D13T115026 2003 350Z R0505

JN1AZ34D83T101415 2003 350Z R0505

JN1AZ34D93T104548 2003 350Z En R0505

JN1AZ34D93T114559 2003 350Z En R0505 PM952

JN1AZ34D93T114559 2003 350Z En P8242

Sub Scrub() Dim DataRange As Range Dim DataSheet As String, SummarySheet As String Dim Digits As String Application.ScreenUpdating = False Set DataRange = Range("A2:C" & Range("A65536").End(xlUp).Row) DataSheet = ActiveSheet.Name Sheets.Add before:=Sheets(DataSheet) SummarySheet = ActiveSheet.Name Sheets(DataSheet).Range("A1:B" & DataRange.Rows.Count).Copy _ Destination:=Range("A1") Sheets(SummarySheet).Range("A1:B" & DataRange.Rows.Count). _ AdvancedFilter Action:=xlFilterCopy, _ CopyToRange:=Range("C1"), Unique:=True Sheets(SummarySheet).Columns("A:B").Delete Shift:=xlToLeft For Each c In Sheets(SummarySheet).Range("A1:A" & _ Sheets(SummarySheet).Range("A65536").End(xlUp).Row) DataRange.AutoFilter Field:=1, Criteria1:=c.Value Digits = "" For Each cell In DataRange. _ Columns("C:C").SpecialCells(xlCellTypeVisible) If cell.Value <> "Campaign #" Then Digits = Digits & cell.Value & " " End If Next cell Digits = Left(Digits, Len(Digits) - 1) c.Offset(0, 2).Value = Digits Next c DataRange.AutoFilter Sheets(SummarySheet).Range("C1").Value = "Campaign #" Range("A1:C1").Select Selection.Font.Bold = True Sheets(SummarySheet).Cells.EntireColumn.AutoFit Application.ScreenUpdating = True End Sub

Hi,

Just to be clear, you have data always in groups of three rowsFor each group of three rows the contents always starts with the same VIN and Model year/name

and in each of the three rows, following the VIN and model year/name you have:

in the first row of the group of three only the first campaign code,

in the second row both the first campaign code and the second campaign code,

and in the third row only the third campaign codeAm I right in thinking that there are never more than three campaign codes and never more than three rows with the same VIN and model year/name

The data you just submitted didn't quite match the pattern in your original question.

Regards

There are only 3 columns, I have over 1100 rows of data each month. I just submitted a small sample to keep it simple. Last month, I had 30 VIN #'s that duplicated so you can see the need to automate the search. As for campaign #'s there could be 1-5 or more but not generally more than 5. Again, I was just trying to simplify the submission but I understand why you asked.

final output wants to be

VIN# Model Campaign# Campaign# Campaign#

Vin# - this is what I'm merging the Camp#'s into a unique VIN# row.

Model - nothing unique, may be duplicated

Campaign# - a series of codes which may be 1 or might be up to 5. This is the 3rd column which I have to merge/consolidate all Campaign#'s on to a single unique VIN# row.

Does this help clear it up?

Hi, I have written a routine that may do what you want.

Based on your comments I created the following source data,

with the first data in Cell B2

(and column titles in row 1, cells B1, C1 and D1)

VIN Model Campaigns JN1AZ34D93T114559 2003 350Z En R0505 PM952 P8242 JN1AZ34D93T114559 2003 350Z En R0505 PM952 P8242 1N4BL21E77C188343 2007 ALTIMA P7221 PM952 P8242 3N1AB61E79L615448 2009 SENTRA R0505 PM953 P7221 JN1AZ34D93T114559 2003 350Z En X5666 Y888 JN1AZ34D93T114559 2003 350Z En X5666 Y888 1N4BL21E77C188343 2007 ALTIMA R0505 P8242 3N1AB61E79L615448 2009 SENTRA X5666 P7221 JN1AZ34D93T114559 2003 350Z En R0505 P8242 JN1AZ34D93T114559 2003 350Z En X5666 P7221 1N4BL21E77C188343 2007 ALTIMA X5666 Y888 3N1AB61E79L615448 2009 SENTRA X5666 Y888 JN1AZ34D93T114559 2003 350Z En P7221 PM952 P8242 JN1AZ34D93T114559 2003 350Z En R0505 PM953 P7221 1N4BL21E77C188343 2007 ALTIMA R0505 PM952 P8242 3N1AB61E79L615448 2009 SENTRA R0505 PM952 P8242 XN1AB61E79L615851 2008 SENTRA Z1234 Z1235

The routine would have to be changed if the data was in a different location.The routine does the following:

Filters all VINs and puts unique VINs in a column

to the right of the source data.Creates an array that links the filtered unique VINs

to all the same VINs in the source data.For each unique VIN finds the model number, then

copies the year and model to the two columns next to the unique VIN,

then checks that each

copy of the unique VIN has the same

model name / year. If not, gives a warning.For each unique VIN, collects all the campaign

numbers.

Then only copies unique campaign numbers, and puts them in a column

to the right of

the model number.The routine has no error checking and I haven't

tested it with the volume of data that you have.The way I create some of the ranges is a bit basic,

and I am sure could be improved upon.The output of the raw data shown above is as follows:

VIN Year Model Campaigns JN1AZ34D93T114559 2003 350Z En PM953 P7221 Y888 X5666 P8242 PM952 R0505 1N4BL21E77C188343 2007 ALTIMA Y888 X5666 R0505 P8242 PM952 P7221 3N1AB61E79L615448 2009 SENTRA P8242 PM952 Y888 X5666 P7221 PM953 R0505 XN1AB61E79L615851 2008 SENTRA Z1235 Z1234The code contains some comments to help identify key parts of the code.

Anyway, here it is, please try it, or let me know if

your source data is not in the format I have used.Sub SortMerge() Dim rngSource As Range Dim intSrcCols As Integer Dim intSrcRows As Integer Dim rngSrcVIN As Range Dim intDestVINCol As Integer Dim rngDestVIN As Range Dim intDestRows As Integer Dim objSrcCell As Range Dim objDestCell As Range Dim varXRefArray() As Variant Dim intMmax As Integer Dim strYearModel As String Dim strYear As String Dim strModel As String Dim strResp As String Dim strCmp() As String Dim strAllCmp As String Dim blnDup As Boolean Dim m As Integer Dim n As Integer Dim o As Integer Dim p As Integer Dim q As Integer Dim s As String With ActiveSheet 'get the range, assuming cell B2 is the first cell with data '- headers are in row 1 Range("B2").Activate Set rngSource = ActiveCell.CurrentRegion intSrcCols = rngSource.Columns.Count intSrcRows = rngSource.Rows.Count - 1 'Get the VIN's in column B - we know how many rows are in use s = "B1:B" & Format(intSrcRows + 1, "0") Set rngSrcVIN = ActiveSheet.Range(s) 'decide where to put the sorted VINs 'B=2 and we know how many columns are in use intDestVINCol = 2 + intSrcCols + 1 s = Chr(64 + intDestVINCol) & "1:" & Chr(64 + intDestVINCol) & "1" Set rngDestVIN = Range(s) 'sort the VIN's and just copy the unique ones rngSrcVIN.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=rngDestVIN, Unique:=True 'find out how many unique VINs we have rngDestVIN.Activate s = rngDestVIN.Address & ":" & ActiveCell.End(xlDown).Address Set rngDestVIN = Range(s) intDestRows = rngDestVIN.Rows.Count 'size the cross-reference array based on the number of unique VINs 'and allow up to 10 source records per unique VIN ReDim varXRefArray(intDestRows, 10) 'create a cross reference array of VINs n = 0 For Each objDestCell In rngDestVIN.Cells 'save the unique VIN address varXRefArray(n, 0) = objDestCell.Address 'look for matches m = 1 For Each objSrcCell In rngSrcVIN.Cells If objSrcCell.Text = objDestCell.Text Then varXRefArray(n, m) = objSrcCell.Address 'keep track of the largest number of X-refs for any unique VIN If m > intMmax Then intMmax = m m = m + 1 End If Next n = n + 1 Next 'now get the year & model for each VIN 'also check that there is only one year and model for each unique VIN 'Array 0 points to the heading text, so ignore it For n = 1 To intDestRows - 1 strYearModel = Range(varXRefArray(n, 1)).Offset(0, 1).Text strYear = Left(strYearModel, 4) strModel = Right(strYearModel, Len(strYearModel) - 5) 'copy the year and model Range(varXRefArray(n, 0)).Offset(0, 1).Value = Trim(strYear) Range(varXRefArray(n, 0)).Offset(0, 2).Value = Trim(strModel) 'check that all the source VINs have the same year and model For m = 1 To intMmax If varXRefArray(n, m) <> "" Then If Range(varXRefArray(n, m)).Offset(0, 1).Text <> strYearModel Then strResp = MsgBox("VIN " & Range(varXRefArray(n, 0)).Text _ & vbCrLf & " has more than one model" & vbCrLf _ & strYearModel & vbCrLf _ & Range(varXRefArray(n, m)).Offset(0, 1).Text & " in cell " _ & varXRefArray(n, m) & vbCrLf _ , vbOKOnly) End If End If Next m Next n 'now get the campaign codes For n = 1 To intDestRows - 1 'clear some variables ReDim strCmp(40) strAllCmp = "" 'and reset the duplicate flag blnDup = False p = 0 For m = 1 To intMmax If varXRefArray(n, m) <> "" Then 'get the campign code or codes s = Range(varXRefArray(n, m)).Offset(0, 2).Text 'break them up into individual codes at the spaces For q = 1 To Len(s) If Mid(s, q, 1) <> " " Then 'store them in an array strCmp(p) = strCmp(p) & Mid(s, q, 1) Else p = p + 1 End If Next q End If p = p + 1 Next m 'accumulate the codes only if they are not duplicated earlier in the array For m = p To 0 Step -1 blnDup = False For o = m - 1 To 0 Step -1 If strCmp(m) = strCmp(o) Then blnDup = True Exit For End If Next o If blnDup = False Then strAllCmp = Trim(strAllCmp) & " " & strCmp(m) End If Next m 'save the accumulated codes Range(varXRefArray(n, 0)).Offset(0, 3).Value = Trim(strAllCmp) Next n End With End SubAlthough I have put the sorted and merged data into separate columns, it is easy to join the data into single cells in the next column. This could be added as extra code or done as a formula.

The campaigns are currently in random order, so an extra step could be added to sort them into order. The campaign codes are assumed to be separated by spaces in the raw data. If this was changed the code would need to be changed.

Hope this is of use to you

Regards

Ask Your Question

Weekly Poll

Do you think Monopoly should update its pieces?

Discuss in The Lounge

Poll History