merging data into unique rows

Microsoft Excel 2003 (full product)
September 10, 2009 at 09:55:14
Specs: Windows XP
I have multiple rows (1100+) with the following format

VIN1 Model1 Campaign1
VIN1 Model1 Campaign1 Campain2
VIN1 Model1 Campaign3

Should 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 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

I'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.


See More: merging data into unique rows

Report •


#1
September 10, 2009 at 10:59:31
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 Campaign3

I'll assume that Campain2 is a typo and should be Campaign2.

The problem I'm having is that in your code, you use lines like:

If cell.Value <> "Campaign #" Then

I 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.


Report •

#2
September 10, 2009 at 11:52:44
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


Report •

#3
September 10, 2009 at 15:34:14
Hi,
Just to be clear, you have data always in groups of three rows

For 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 code

Am 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


Report •

Related Solutions

#4
September 10, 2009 at 17:57:31
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?


Report •

#5
September 11, 2009 at 18:00:07
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 Z1234

The 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 Sub

Although 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


Report •


Ask Question