Combine two records into one based on a different tab

SpunkyElderBerry

New Member
Joined
Jan 12, 2017
Messages
1
Hello,

I'm in the process of expanding on a macro to look at customer ID and the product name they ordered. If they ordered a set of a particular product then it will combine both product name into one and delete the oldest record.




I have created another tab that combines the product name condensed based on the following

Test 1Test 2Test To use
ABC123ABC456ABC123456
PEN541PENV2PEN541V2


<tbody>
</tbody>



For example here is a small list of customers that has two products. Based on the table above if a customer has test 1 and test 2 then it should be combine into "Test to use".
Record #Customer NameProduct NameProduct Name Condensed
101James SmithABC-123ABC123
101James SmithABC-456ABC456
202Jill JonesPEN-541PEN541
202Jill JonesPEN-V2PENV2

<tbody>
</tbody>

The output of the macro should be the following:
Record #Customer NameProduct NameProduct Name Condensed
101James SmithABC123456ABC123456
202Jill JonesPEN541V2PEN541V2

<tbody>
</tbody>




Here if the code i been using thus far

Code:
Sub DupTestDelete()
'
' MaskDuplicateTests Macro
'
' Keyboard Shortcut: Ctrl+Shift+A
'
Sheets("Tests").Activate
For i = 2 To Sheets.Count
    pickTest.ComboBox1.AddItem Sheets(i).Name
Next i
pickTest.Show
End Sub


Sub MaskDuplicateTests(pickedTest As String)


screenUpdateState = Application.ScreenUpdating
statusBarState = Application.DisplayStatusBar
calcState = Application.Calculation
eventsState = Application.EnableEvents
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Dim acc As Long
acc = Cells.Find(What:="Record #", LookIn:=xlFormulas, LookAt:= _
       xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
       , SearchFormat:=False).Column
Dim patID As Long
patID = Cells.Find(What:="Customer ID", LookIn:=xlFormulas, LookAt:= _
       xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
       , SearchFormat:=False).Column
Dim TestName As Long
TestName = Cells.Find(What:="Product Name", LookIn:=xlFormulas, LookAt:= _
       xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
       , SearchFormat:=False).Column
Dim TestNameCon As Long
TestNameCon = Cells.Find(What:="Product Name Condensed", LookIn:=xlFormulas, LookAt:= _
       xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
       , SearchFormat:=False).Column
If TestName = TestNameCon Then
    TestName = Cells.Find(What:="Test Name", LookIn:=xlFormulas, LookAt:= _
       xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
       , SearchFormat:=False).Column
End If
Dim x As Long
Dim y As Long
Dim firstTest As String
Dim secondTest As String
x = 2
Do While Sheets("Tests").Cells(x, 1).Value <> ""
    If Sheets("Tests").Cells(x, patID).Value = Sheets("Tests").Cells(x + 1, patID).Value Then
        firstTest = LCase(Trim(Sheets("Tests").Cells(x, TestNameCon).Text))
        secondTest = LCase(Trim(Sheets("Tests").Cells(x + 1, TestNameCon).Text))
        If firstTest = secondTest Then
            If Sheets("Tests").Cells(x, acc).Value > Sheets("Tests").Cells(x + 1, acc).Value Then
                Sheets("Tests").Rows(x + 1).Delete
            ElseIf Sheets("Tests").Cells(x, acc).Value < Sheets("Tests").Cells(x + 1, acc).Value Then
                Sheets("Tests").Rows(x).Delete
            Else
                If InStr(LCase(Sheets("Tests").Cells(x, TestName).Text), "step2") > 0 Then
                    Sheets("Tests").Rows(x + 1).Delete
                ElseIf InStr(LCase(Sheets("Tests").Cells(x + 1, TestName).Text), "step2") > 0 Then
                    Sheets("Tests").Rows(x).Delete
                Else
                    x = x + 1
                End If
            End If
            GoTo vbaNeedsContinueStatements
        End If
        y = 2
        Do While Sheets(pickedTest).Cells(y, 1).Value <> ""
            If LCase(Trim(Sheets(pickedTest).Cells(y, 1).Text)) = firstTest Then
                If LCase(Trim(Sheets(pickedTest).Cells(y, 2).Text)) = secondTest Or LCase(Trim(Sheets(pickedTest).Cells(y, 2).Text)) = "anything" Then
                    If LCase(Trim(Sheets(pickedTest).Cells(y, 3).Text)) = "both" Then
                    ElseIf LCase(Trim(Sheets(pickedTest).Cells(y, 3).Text)) = firstTest Then
                        Sheets("Tests").Rows(x + 1).Delete
                        x = x - 1
                    Else
                        Sheets("Tests").Rows(x).Delete
                        x = x - 1
                    End If
                    Exit Do
                End If
            ElseIf LCase(Trim(Sheets(pickedTest).Cells(y, 1).Text)) = secondTest Then
                If LCase(Trim(Sheets(pickedTest).Cells(y, 2).Text)) = firstTest Or LCase(Trim(Sheets(pickedTest).Cells(y, 2).Text)) = "anything" Then
                    If LCase(Trim(Sheets(pickedTest).Cells(y, 3).Text)) = "both" Then
                    ElseIf LCase(Trim(Sheets(pickedTest).Cells(y, 3).Text)) = firstTest Then
                        Sheets("Tests").Rows(x + 1).Delete
                        x = x - 1
                    Else
                        Sheets("Tests").Rows(x).Delete
                        x = x - 1
                    End If
                    Exit Do
                End If
            End If
            y = y + 1
        Loop
    End If
    x = x + 1
vbaNeedsContinueStatements:
Loop
Application.ScreenUpdating = screenUpdateState
Application.DisplayStatusBar = statusBarState
Application.Calculation = calcState
Application.EnableEvents = eventsState
End Sub


Any help would be much appreciated. Thanks in advanced!
 

Some videos you may like

Excel Facts

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.

Watch MrExcel Video

Forum statistics

Threads
1,122,499
Messages
5,596,517
Members
414,074
Latest member
Matthew Kakde

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top