Make this Macro Work with more rows?

J

jeffcoleky

Active Member
Joined
May 24, 2011
Messages
274
I have created a macro that works, but it only works with my specific example data. If there are more or less rows, or different data in the cells, it will not work because it is not written dynamically. I lack the skillset to make it dynamic also :)

Link Example data containing Macro: https://1drv.ms/x/s!AmDnPhDNb87xmgbVlpKgTJU58I6y (shared via OneDrive)

Objective: Modify Data so that I can easily use mail-merge to Mail a letter individually two both people in each row at both addresses (if two different addresses exist different)

Here are the steps the macro takes:

  • Copy each Row with that has data in column E, paste value in first empty row

  • For each of those Duplicated Rows, Copy data from E:F and overwrite values in C:D

  • Delete Columns E:F (Because Both Names are now in Columns C:D instead)

  • Duplicate all Rows (Except for header row) and paste below in first empty row

  • For each duplicated row, copy data from I:L and overwrite the values in E:H

  • Delete Columns I:L (because both addresses are now in columns E:H instead)

  • Sort Column A in ascending order

  • Select all, Remove Duplicates (where A:H are the same)


Here is the current macro:
Code: 
 Sub MailMergePrep()' MailPrep Macro
' Objective of Macro: Modify Data so that I can easily use mail-merge to Mail a letter individually two both people in each row at both addresses (if two different addresses exist different)
' *Currently this macro only Functions with existing example data ONLY. Not Dynamic. Needs fixing :(


'#1 Copy each Row with that has data in column E, paste value in first empty row
    Rows("3:4").Select
    Selection.Copy
    Rows("19:19").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    Rows("6:6").Select
    Application.CutCopyMode = False
    Selection.Copy
    Rows("21:21").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    Rows("13:13").Select
    Application.CutCopyMode = False
    Selection.Copy
    Rows("22:22").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    Rows("17:18").Select
    Application.CutCopyMode = False
    Selection.Copy
    Rows("23:23").Select
    Selection.Insert Shift:=xlDown
    
'#2 For each of those Duplicated Rows, Copy data from E:F and overwrite values in C:D
    Range("E19:F24").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("C19").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
'#3 Delete Columns E:F (Because Both Names are now in Columns C:D instead)
    Columns("E:F").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    
'#4 Duplicate all Rows (Except for header row) and paste below in first empty row
    Rows("2:24").Select
    Selection.Copy
    Rows("25:25").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
'#5 For each duplicated row, copy data from I:L and overwrite the values in E:H
    Range("I25:L47").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("E25").Select
    ActiveSheet.Paste
    
'#6 Delete Columns I:L (because both addresses are now in columns E:H instead)
    Columns("I:L").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
      
'#7 Sort Column A in ascending order
    ActiveWorkbook.Worksheets("Data Before").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Data Before").AutoFilter.Sort.SortFields.Add Key:= _
        Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("Data Before").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
      
'#8 Select all, Remove Duplicates (where A:H are the same)
    Cells.Select
    Range("I1").Activate
    ActiveSheet.Range("$A$1:$N$47").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7 _
        , 8, 9, 10, 11, 12, 13, 14), Header:=xlYes
    
End Sub

<tbody> </tbody>

Example RAW data (Before macro):

ID#BOTH-NamesFirstLastFirst2Last2StreetCityStateZipStreetBCityBStateBZipB
ABC123Thomas JonesesThomasJoneses1151 Glenhurst AveShepherdsNC509168189 CHRISTIAN CT APT 893ShepherdsNC50922
ABC124Fidel & Maria SmartieFidelSmartieMariaSmartie5991 Braidwood DrShepherdsNC509195991 BRAIDWOOD DRShepherdsNC50919
ABC125Jackie & Christina SpitterJackieSpitterChristinaSpitter5718 Midnight LnShepherdsNC509295718 MIDNIGHT LNShepherdsNC50929
ABC126Donald LuluDonaldLulu9118 Galene DrShepherdsNC509999118 GALENE DRShepherdsNC50999
ABC127George & Dorothy HardGeorgeHardDorothyHard1811 Libby LnShepherdsNC509727816 RUTLEDGE RDShepherdsNC50958
ABC128Samantha DavenportSamanthaDavenport7919 Black Walnut CirShepherdsNC509297919 BLACK WALNUT CIRShepherdsNC50929
ABC129Jackie KatnipJackieKatnip3399 Ethelwood DrShepherdsNC509993399 ETHELWOOD DRShepherdsNC50999
ABC130Mary SmithieMarySmithie8985 Dogoon DrShepherdsNC509238985 DOGOON DRShepherdsNC50923
ABC131Wanda ChefWandaChef6817 Carolina AveShepherdsNC509587691 NANCY LNShepherdsNC50958
ABC132Antoine WhoAntoineWho939 Francis AveShepherdsNC50914939 E FRANCIS AVE APT 8ShepherdsNC50914
ABC133Joshua ReevesJoshuaReeves1698 Kerrick LnShepherdsNC509587319 AUSTINWOOD RDShepherdsNC50914
ABC134Zachariah & Brittany SoupZachariahSoupBrittanySoup6118 Highgrade DrShepherdsNC509916118 HIGHGRADE DRShepherdsNC50991
ABC135Clyda GreenClydaGreen889 Mcbroom DrShepherdsNC50914889 MCBROOM DRShepherdsNC50914
ABC136Latoscia CivilLatosciaCivil7189 Spring Run DrShepherdsNC509917189 SPRING RUN DRShepherdsNC50991
ABC137Thomas TomtomThomasTomtom898 S Keats AveShepherdsNC50906898 S KEATS AVEShepherdsNC50906
ABC138Ju & Jeron GreatJuGreatJeronGreat9191 Walter AveShepherdsNC509159191 WALTER AVEShepherdsNC50915
ABC139Robt & Mary SalmonRobtSalmonMarySalmon883 Marytena DrShepherdsNC50914883 MARYTENA DRShepherdsNC50914

<tbody>
</tbody>


Example of what data should look like AFTER macro:


ID#BOTH-NamesFirstLastStreetCityStateZip
ABC123Thomas JonesesThomasJoneses1151 Glenhurst AveShepherdsNC50916
ABC123Thomas JonesesThomasJoneses8189 CHRISTIAN CT APT 893ShepherdsNC50922
ABC124Fidel & Maria SmartieFidelSmartie5991 Braidwood DrShepherdsNC50919
ABC124Fidel & Maria SmartieMariaSmartie5991 Braidwood DrShepherdsNC50919
ABC125Jackie & Christina SpitterJackieSpitter5718 Midnight LnShepherdsNC50929
ABC125Jackie & Christina SpitterChristinaSpitter5718 Midnight LnShepherdsNC50929
ABC126Donald LuluDonaldLulu9118 Galene DrShepherdsNC50999
ABC127George & Dorothy HardGeorgeHard1811 Libby LnShepherdsNC50972
ABC127George & Dorothy HardDorothyHard1811 Libby LnShepherdsNC50972
ABC127George & Dorothy HardGeorgeHard7816 RUTLEDGE RDShepherdsNC50958
ABC127George & Dorothy HardDorothyHard7816 RUTLEDGE RDShepherdsNC50958
ABC128Samantha DavenportSamanthaDavenport7919 Black Walnut CirShepherdsNC50929
ABC129Jackie KatnipJackieKatnip3399 Ethelwood DrShepherdsNC50999
ABC130Mary SmithieMarySmithie8985 Dogoon DrShepherdsNC50923
ABC131Wanda ChefWandaChef6817 Carolina AveShepherdsNC50958
ABC131Wanda ChefWandaChef7691 NANCY LNShepherdsNC50958
ABC132Antoine WhoAntoineWho939 Francis AveShepherdsNC50914
ABC132Antoine WhoAntoineWho939 E FRANCIS AVE APT 8ShepherdsNC50914
ABC133Joshua ReevesJoshuaReeves1698 Kerrick LnShepherdsNC50958
ABC133Joshua ReevesJoshuaReeves7319 AUSTINWOOD RDShepherdsNC50914
ABC134Zachariah & Brittany SoupZachariahSoup6118 Highgrade DrShepherdsNC50991
ABC134Zachariah & Brittany SoupBrittanySoup6118 Highgrade DrShepherdsNC50991
ABC135Clyda GreenClydaGreen889 Mcbroom DrShepherdsNC50914
ABC136Latoscia CivilLatosciaCivil7189 Spring Run DrShepherdsNC50991
ABC137Thomas TomtomThomasTomtom898 S Keats AveShepherdsNC50906
ABC138Ju & Jeron GreatJuGreat9191 Walter AveShepherdsNC50915
ABC138Ju & Jeron GreatJeronGreat9191 Walter AveShepherdsNC50915
ABC139Robt & Mary SalmonRobtSalmon883 Marytena DrShepherdsNC50914
ABC139Robt & Mary SalmonMarySalmon883 Marytena DrShepherdsNC50914

<tbody>
</tbody>


(Note that a link to a file with all the example data can be found above)
 

Excel Facts

Create a Pivot Table on a Map
If your data has zip codes, postal codes, or city names, select the data and use Insert, 3D Map. (Found to right of chart icons).
Sort by date Sort by votes
Re: Macro Help: Make this Macro Work with more rows?

try this

Code: 
Sub MailMergePrep() ' MailPrep Macro
Dim wb As Workbook
Dim ws As Worksheet
Dim lngROW As Long, lngCOL As Long
Dim cell As Range, rng As Range, rngID As Range
Dim intCITY1 As Integer, intCITY2 As Integer, intST1 As Integer, _
    intST2 As Integer, intSTATE1 As Integer, intSTATE2 As Integer, _
    intZIP1 As Integer, intZIP2 As Integer, intFN1 As Integer, _
    intFN2 As Integer, intLN1 As Integer, intLN2 As Integer, _
    intID As Integer, intBN As Integer, intSTROW As Integer, _
    intDEL As Integer
Dim strST1 As String, strST2 As String, strNAME As String

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    Set wb = ThisWorkbook
    Set ws = wb.Sheets("jeffcoleky") 'change this sheet name to your sheet name
    With ws
        lngROW = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
        intSTROW = lngROW + 2
        lngCOL = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
        Set rng = ws.Range(ws.Cells(1, 1), ws.Cells(1, lngCOL))
        intCITY1 = rng.Find("City", LookAt:=xlWhole).Column
        intCITY2 = rng.Find("CityB", LookAt:=xlWhole).Column
        intST1 = rng.Find("Street", LookAt:=xlWhole).Column
        intST2 = rng.Find("StreetB", LookAt:=xlWhole).Column
        intSTATE1 = rng.Find("State", LookAt:=xlWhole).Column
        intSTATE2 = rng.Find("StateB", LookAt:=xlWhole).Column
        intZIP1 = rng.Find("Zip", LookAt:=xlWhole).Column
        intZIP2 = rng.Find("ZipB", LookAt:=xlWhole).Column
        intFN1 = rng.Find("First", LookAt:=xlWhole).Column
        intFN2 = rng.Find("First2", LookAt:=xlWhole).Column
        intLN1 = rng.Find("Last", LookAt:=xlWhole).Column
        intLN2 = rng.Find("Last2", LookAt:=xlWhole).Column
        intID = rng.Find("ID#", LookAt:=xlWhole).Column
        intBN = rng.Find("BOTH-Names", LookAt:=xlWhole).Column
        rng.Copy
        ws.Cells(intSTROW, 1).PasteSpecial xlPasteAll
        ws.Range(ws.Cells(intSTROW, intST2), ws.Cells(intSTROW, intZIP2)).Delete
        Set rngID = ws.Range(ws.Cells(2, 1), ws.Cells(lngROW, 1))
        intDEL = lngROW + 1
        For Each cell In rngID
            lngROW = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
            Set rng = ws.Cells(lngROW + 1, 1)
            rng.Value = cell.Value
            If ws.Cells(cell.Row, intFN2).Value = "" Then
                strNAME = ws.Cells(cell.Row, intFN1).Value & " " _
                    & ws.Cells(cell.Row, intLN1).Value
            Else
                If ws.Cells(cell.Row, intLN1).Value = ws.Cells(cell.Row, _
                        intLN2).Value Then
                    strNAME = ws.Cells(cell.Row, intFN1).Value & " & " _
                        & ws.Cells(cell.Row, intFN2).Value & " " _
                        & ws.Cells(cell.Row, intLN1).Value
                Else
                    strNAME = ws.Cells(cell.Row, intFN1).Value & " " _
                        & ws.Cells(cell.Row, intLN1) & " & " _
                        & ws.Cells(cell.Row, intFN2).Value & " " _
                        & ws.Cells(cell.Row, intLN2).Value
                End If
            End If
            rng.Offset(, 1).Value = strNAME
            rng.Offset(, 2).Value = ws.Cells(cell.Row, intFN1).Value
            rng.Offset(, 3).Value = ws.Cells(cell.Row, intLN1).Value
            rng.Offset(, 4).Value = ""
            rng.Offset(, 5).Value = ""
            rng.Offset(, 6).Value = ws.Cells(cell.Row, intST1).Value
            rng.Offset(, 7).Value = ws.Cells(cell.Row, intCITY1).Value
            rng.Offset(, 8).Value = ws.Cells(cell.Row, intSTATE1).Value
            rng.Offset(, 9).Value = ws.Cells(cell.Row, intZIP1).Value
            strST1 = UCase(ws.Cells(cell.Row, intST1))
            strST2 = UCase(ws.Cells(cell.Row, intST2))
            If Not strST1 = strST2 Then
                rng.Offset(1).Value = cell.Value
                rng.Offset(1, 1).Value = strNAME
                rng.Offset(1, 2).Value = ws.Cells(cell.Row, intFN1).Value
                rng.Offset(1, 3).Value = ws.Cells(cell.Row, intLN1).Value
                rng.Offset(1, 4).Value = ""
                rng.Offset(1, 5).Value = ""
                rng.Offset(1, 6).Value = ws.Cells(cell.Row, intST2).Value
                rng.Offset(1, 7).Value = ws.Cells(cell.Row, intCITY2).Value
                rng.Offset(1, 8).Value = ws.Cells(cell.Row, intSTATE2).Value
                rng.Offset(1, 9).Value = ws.Cells(cell.Row, intZIP2).Value
            End If
        Next cell
        ws.Range(ws.Cells(1, 1), ws.Cells(intDEL, lngCOL)).EntireRow.Delete
        ws.Range(ws.Cells(1, intFN2), ws.Cells(1, intLN2)).EntireColumn.Delete
        lngROW = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
        lngCOL = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
        Set rng = ws.Range(ws.Cells(1, intBN), ws.Cells(lngROW, lngCOL))
        rng.Select
        rng.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7), Header:=xlYes
        With Application
            .ScreenUpdating = True
            .Calculation = xlCalculationAutomatic
            .DisplayAlerts = True
        End With
    End With
End Sub
 
Upvote 0
Re: Macro Help: Make this Macro Work with more rows?

It's not quite there. Thanks for taking the time! It does do a good job with capturing the StreetB information, but it fails to capture the First2 and Last2 names. I'm not sure when or why though... The end result is 23 rows of data instead of 30.

RCBricker said:
try this

Code: 
Sub MailMergePrep() ' MailPrep Macro
Dim wb As Workbook
Dim ws As Worksheet
Dim lngROW As Long, lngCOL As Long
Dim cell As Range, rng As Range, rngID As Range
Dim intCITY1 As Integer, intCITY2 As Integer, intST1 As Integer, _
    intST2 As Integer, intSTATE1 As Integer, intSTATE2 As Integer, _
    intZIP1 As Integer, intZIP2 As Integer, intFN1 As Integer, _
    intFN2 As Integer, intLN1 As Integer, intLN2 As Integer, _
    intID As Integer, intBN As Integer, intSTROW As Integer, _
    intDEL As Integer
Dim strST1 As String, strST2 As String, strNAME As String

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    Set wb = ThisWorkbook
    Set ws = wb.Sheets("jeffcoleky") 'change this sheet name to your sheet name
    With ws
        lngROW = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
        intSTROW = lngROW + 2
        lngCOL = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
        Set rng = ws.Range(ws.Cells(1, 1), ws.Cells(1, lngCOL))
        intCITY1 = rng.Find("City", LookAt:=xlWhole).Column
        intCITY2 = rng.Find("CityB", LookAt:=xlWhole).Column
        intST1 = rng.Find("Street", LookAt:=xlWhole).Column
        intST2 = rng.Find("StreetB", LookAt:=xlWhole).Column
        intSTATE1 = rng.Find("State", LookAt:=xlWhole).Column
        intSTATE2 = rng.Find("StateB", LookAt:=xlWhole).Column
        intZIP1 = rng.Find("Zip", LookAt:=xlWhole).Column
        intZIP2 = rng.Find("ZipB", LookAt:=xlWhole).Column
        intFN1 = rng.Find("First", LookAt:=xlWhole).Column
        intFN2 = rng.Find("First2", LookAt:=xlWhole).Column
        intLN1 = rng.Find("Last", LookAt:=xlWhole).Column
        intLN2 = rng.Find("Last2", LookAt:=xlWhole).Column
        intID = rng.Find("ID#", LookAt:=xlWhole).Column
        intBN = rng.Find("BOTH-Names", LookAt:=xlWhole).Column
        rng.Copy
        ws.Cells(intSTROW, 1).PasteSpecial xlPasteAll
        ws.Range(ws.Cells(intSTROW, intST2), ws.Cells(intSTROW, intZIP2)).Delete
        Set rngID = ws.Range(ws.Cells(2, 1), ws.Cells(lngROW, 1))
        intDEL = lngROW + 1
        For Each cell In rngID
            lngROW = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
            Set rng = ws.Cells(lngROW + 1, 1)
            rng.Value = cell.Value
            If ws.Cells(cell.Row, intFN2).Value = "" Then
                strNAME = ws.Cells(cell.Row, intFN1).Value & " " _
                    & ws.Cells(cell.Row, intLN1).Value
            Else
                If ws.Cells(cell.Row, intLN1).Value = ws.Cells(cell.Row, _
                        intLN2).Value Then
                    strNAME = ws.Cells(cell.Row, intFN1).Value & " & " _
                        & ws.Cells(cell.Row, intFN2).Value & " " _
                        & ws.Cells(cell.Row, intLN1).Value
                Else
                    strNAME = ws.Cells(cell.Row, intFN1).Value & " " _
                        & ws.Cells(cell.Row, intLN1) & " & " _
                        & ws.Cells(cell.Row, intFN2).Value & " " _
                        & ws.Cells(cell.Row, intLN2).Value
                End If
            End If
            rng.Offset(, 1).Value = strNAME
            rng.Offset(, 2).Value = ws.Cells(cell.Row, intFN1).Value
            rng.Offset(, 3).Value = ws.Cells(cell.Row, intLN1).Value
            rng.Offset(, 4).Value = ""
            rng.Offset(, 5).Value = ""
            rng.Offset(, 6).Value = ws.Cells(cell.Row, intST1).Value
            rng.Offset(, 7).Value = ws.Cells(cell.Row, intCITY1).Value
            rng.Offset(, 8).Value = ws.Cells(cell.Row, intSTATE1).Value
            rng.Offset(, 9).Value = ws.Cells(cell.Row, intZIP1).Value
            strST1 = UCase(ws.Cells(cell.Row, intST1))
            strST2 = UCase(ws.Cells(cell.Row, intST2))
            If Not strST1 = strST2 Then
                rng.Offset(1).Value = cell.Value
                rng.Offset(1, 1).Value = strNAME
                rng.Offset(1, 2).Value = ws.Cells(cell.Row, intFN1).Value
                rng.Offset(1, 3).Value = ws.Cells(cell.Row, intLN1).Value
                rng.Offset(1, 4).Value = ""
                rng.Offset(1, 5).Value = ""
                rng.Offset(1, 6).Value = ws.Cells(cell.Row, intST2).Value
                rng.Offset(1, 7).Value = ws.Cells(cell.Row, intCITY2).Value
                rng.Offset(1, 8).Value = ws.Cells(cell.Row, intSTATE2).Value
                rng.Offset(1, 9).Value = ws.Cells(cell.Row, intZIP2).Value
            End If
        Next cell
        ws.Range(ws.Cells(1, 1), ws.Cells(intDEL, lngCOL)).EntireRow.Delete
        ws.Range(ws.Cells(1, intFN2), ws.Cells(1, intLN2)).EntireColumn.Delete
        lngROW = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
        lngCOL = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
        Set rng = ws.Range(ws.Cells(1, intBN), ws.Cells(lngROW, lngCOL))
        rng.Select
        rng.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7), Header:=xlYes
        With Application
            .ScreenUpdating = True
            .Calculation = xlCalculationAutomatic
            .DisplayAlerts = True
        End With
    End With
End Sub
Click to expand...
 
Last edited:
Upvote 0
Re: Macro Help: Make this Macro Work with more rows?

To clarify: If a row were to have two full names AND two different addresses, you'd have 4 rows for one ID#. Currently, it only does one name for two addresses. Maybe there's an IF statement misplaced?

Here's how a record with two full names and two different addresses should process:

ID#BOTH-NamesFirstLastFirst2Last2StreetCityStateZipStreetBCityBStateBZipB
ABC127George & Dorothy HardGeorgeHardDorothyHard1811 Libby LnShepherdsNC509727816 RUTLEDGE RDShepherdsNC50958

<thead>
</thead><tbody>
</tbody>

Turns into:

ID#BOTH-NamesFirstLastStreetCityStateZip
ABC127George & Dorothy HardGeorgeHard1811 Libby LnShepherdsNC50972
ABC127George & Dorothy HardDorothyHard1811 Libby LnShepherdsNC50972
ABC127George & Dorothy HardGeorgeHard7816 RUTLEDGE RDShepherdsNC50958
ABC127George & Dorothy HardDorothyHard7816 RUTLEDGE RDShepherdsNC50958

<thead>
</thead><tbody>
</tbody>


(The order of the results doesn't matter)
 
Upvote 0
Re: Macro Help: Make this Macro Work with more rows?

missed that condition.

try this

Code: 
Sub MailMergePrep() ' MailPrep Macro
Dim wb As Workbook
Dim ws As Worksheet
Dim lngROW As Long, lngCOL As Long
Dim cell As Range, rng As Range, rngID As Range
Dim intCITY1 As Integer, intCITY2 As Integer, intST1 As Integer, _
    intST2 As Integer, intSTATE1 As Integer, intSTATE2 As Integer, _
    intZIP1 As Integer, intZIP2 As Integer, intFN1 As Integer, _
    intFN2 As Integer, intLN1 As Integer, intLN2 As Integer, _
    intID As Integer, intBN As Integer, intSTROW As Integer, _
    intDEL As Integer
Dim strST1 As String, strST2 As String, strNAME As String, strREC As String

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    Set wb = ThisWorkbook
    Set ws = wb.Sheets("jeffcoleky") 'change this sheet name to your sheet name
    With ws
        lngROW = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
        intSTROW = lngROW + 2
        lngCOL = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
        Set rng = ws.Range(ws.Cells(1, 1), ws.Cells(1, lngCOL))
        intCITY1 = rng.Find("City", LookAt:=xlWhole).Column
        intCITY2 = rng.Find("CityB", LookAt:=xlWhole).Column
        intST1 = rng.Find("Street", LookAt:=xlWhole).Column
        intST2 = rng.Find("StreetB", LookAt:=xlWhole).Column
        intSTATE1 = rng.Find("State", LookAt:=xlWhole).Column
        intSTATE2 = rng.Find("StateB", LookAt:=xlWhole).Column
        intZIP1 = rng.Find("Zip", LookAt:=xlWhole).Column
        intZIP2 = rng.Find("ZipB", LookAt:=xlWhole).Column
        intFN1 = rng.Find("First", LookAt:=xlWhole).Column
        intFN2 = rng.Find("First2", LookAt:=xlWhole).Column
        intLN1 = rng.Find("Last", LookAt:=xlWhole).Column
        intLN2 = rng.Find("Last2", LookAt:=xlWhole).Column
        intID = rng.Find("ID#", LookAt:=xlWhole).Column
        intBN = rng.Find("BOTH-Names", LookAt:=xlWhole).Column
        rng.Copy
        ws.Cells(intSTROW, 1).PasteSpecial xlPasteAll
        ws.Range(ws.Cells(intSTROW, intST2), ws.Cells(intSTROW, intZIP2)).Delete
        Set rngID = ws.Range(ws.Cells(2, 1), ws.Cells(lngROW, 1))
        
        
        intDEL = lngROW + 1

        For Each cell In rngID
            strST1 = UCase(ws.Cells(cell.Row, intST1))
            strST2 = UCase(ws.Cells(cell.Row, intST2))
            lngROW = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
            Set rng = ws.Cells(lngROW + 1, 1)
            rng.Value = cell.Value
            
            strREC = "A"
            If Not ws.Cells(cell.Row, intFN2).Value = "" Then
                strREC = strREC & "B"
            End If
            If Not strST1 = strST2 Then
                strREC = strREC & "C"
            End If
            Select Case strREC
                Case "A"
                    strNAME = ws.Cells(cell.Row, intFN1).Value & " " _
                        & ws.Cells(cell.Row, intLN1).Value
                    rng.Value = cell.Value
                    rng.Offset(, 1).Value = strNAME
                    rng.Offset(, 2).Value = ws.Cells(cell.Row, intFN1).Value
                    rng.Offset(, 3).Value = ws.Cells(cell.Row, intLN1).Value
                    rng.Offset(, 4).Value = ""
                    rng.Offset(, 5).Value = ""
                    rng.Offset(, 6).Value = ws.Cells(cell.Row, intST1).Value
                    rng.Offset(, 7).Value = ws.Cells(cell.Row, intCITY1).Value
                    rng.Offset(, 8).Value = ws.Cells(cell.Row, intSTATE1).Value
                    rng.Offset(, 9).Value = ws.Cells(cell.Row, intZIP1).Value
                Case "AB"
                    If ws.Cells(cell.Row, intLN1).Value = ws.Cells(cell.Row, _
                            intLN2).Value Then
                        strNAME = ws.Cells(cell.Row, intFN1).Value & " & " _
                            & ws.Cells(cell.Row, intFN2).Value & " " _
                            & ws.Cells(cell.Row, intLN1).Value
                    Else
                        strNAME = ws.Cells(cell.Row, intFN1).Value & " " _
                            & ws.Cells(cell.Row, intLN1) & " & " _
                            & ws.Cells(cell.Row, intFN2).Value & " " _
                            & ws.Cells(cell.Row, intLN2).Value
                    End If
                    rng.Value = cell.Value
                    rng.Offset(, 1).Value = strNAME
                    rng.Offset(, 2).Value = ws.Cells(cell.Row, intFN1).Value
                    rng.Offset(, 3).Value = ws.Cells(cell.Row, intLN1).Value
                    rng.Offset(, 4).Value = ""
                    rng.Offset(, 5).Value = ""
                    rng.Offset(, 6).Value = ws.Cells(cell.Row, intST1).Value
                    rng.Offset(, 7).Value = ws.Cells(cell.Row, intCITY1).Value
                    rng.Offset(, 8).Value = ws.Cells(cell.Row, intSTATE1).Value
                    rng.Offset(, 9).Value = ws.Cells(cell.Row, intZIP1).Value
                    
                    rng.Offset(1).Value = cell.Value
                    rng.Offset(1, 1).Value = strNAME
                    rng.Offset(1, 2).Value = ws.Cells(cell.Row, intFN2).Value
                    rng.Offset(1, 3).Value = ws.Cells(cell.Row, intLN2).Value
                    rng.Offset(1, 4).Value = ""
                    rng.Offset(1, 5).Value = ""
                    rng.Offset(1, 6).Value = ws.Cells(cell.Row, intST1).Value
                    rng.Offset(1, 7).Value = ws.Cells(cell.Row, intCITY1).Value
                    rng.Offset(1, 8).Value = ws.Cells(cell.Row, intSTATE1).Value
                    rng.Offset(1, 9).Value = ws.Cells(cell.Row, intZIP1).Value
                Case "AC"
                    strNAME = ws.Cells(cell.Row, intFN1).Value & " " _
                        & ws.Cells(cell.Row, intLN1).Value
                    rng.Value = cell.Value
                    rng.Offset(, 1).Value = strNAME
                    rng.Offset(, 2).Value = ws.Cells(cell.Row, intFN1).Value
                    rng.Offset(, 3).Value = ws.Cells(cell.Row, intLN1).Value
                    rng.Offset(, 4).Value = ""
                    rng.Offset(, 5).Value = ""
                    rng.Offset(, 6).Value = ws.Cells(cell.Row, intST1).Value
                    rng.Offset(, 7).Value = ws.Cells(cell.Row, intCITY1).Value
                    rng.Offset(, 8).Value = ws.Cells(cell.Row, intSTATE1).Value
                    rng.Offset(, 9).Value = ws.Cells(cell.Row, intZIP1).Value
                    
                    rng.Offset(1).Value = cell.Value
                    rng.Offset(1, 1).Value = strNAME
                    rng.Offset(1, 2).Value = ws.Cells(cell.Row, intFN1).Value
                    rng.Offset(1, 3).Value = ws.Cells(cell.Row, intLN1).Value
                    rng.Offset(1, 4).Value = ""
                    rng.Offset(1, 5).Value = ""
                    rng.Offset(1, 6).Value = ws.Cells(cell.Row, intST2).Value
                    rng.Offset(1, 7).Value = ws.Cells(cell.Row, intCITY2).Value
                    rng.Offset(1, 8).Value = ws.Cells(cell.Row, intSTATE2).Value
                    rng.Offset(1, 9).Value = ws.Cells(cell.Row, intZIP2).Value
                Case "ABC"
                    If ws.Cells(cell.Row, intLN1).Value = ws.Cells(cell.Row, _
                            intLN2).Value Then
                        strNAME = ws.Cells(cell.Row, intFN1).Value & " & " _
                            & ws.Cells(cell.Row, intFN2).Value & " " _
                            & ws.Cells(cell.Row, intLN1).Value
                    Else
                        strNAME = ws.Cells(cell.Row, intFN1).Value & " " _
                            & ws.Cells(cell.Row, intLN1) & " & " _
                            & ws.Cells(cell.Row, intFN2).Value & " " _
                            & ws.Cells(cell.Row, intLN2).Value
                    End If
                    rng.Value = cell.Value
                    rng.Offset(, 1).Value = strNAME
                    rng.Offset(, 2).Value = ws.Cells(cell.Row, intFN1).Value
                    rng.Offset(, 3).Value = ws.Cells(cell.Row, intLN1).Value
                    rng.Offset(, 4).Value = ""
                    rng.Offset(, 5).Value = ""
                    rng.Offset(, 6).Value = ws.Cells(cell.Row, intST1).Value
                    rng.Offset(, 7).Value = ws.Cells(cell.Row, intCITY1).Value
                    rng.Offset(, 8).Value = ws.Cells(cell.Row, intSTATE1).Value
                    rng.Offset(, 9).Value = ws.Cells(cell.Row, intZIP1).Value
                    
                    rng.Offset(1).Value = cell.Value
                    rng.Offset(1, 1).Value = strNAME
                    rng.Offset(1, 2).Value = ws.Cells(cell.Row, intFN2).Value
                    rng.Offset(1, 3).Value = ws.Cells(cell.Row, intLN2).Value
                    rng.Offset(1, 4).Value = ""
                    rng.Offset(1, 5).Value = ""
                    rng.Offset(1, 6).Value = ws.Cells(cell.Row, intST1).Value
                    rng.Offset(1, 7).Value = ws.Cells(cell.Row, intCITY1).Value
                    rng.Offset(1, 8).Value = ws.Cells(cell.Row, intSTATE1).Value
                    rng.Offset(1, 9).Value = ws.Cells(cell.Row, intZIP1).Value
                    
                    rng.Offset(2).Value = cell.Value
                    rng.Offset(2, 1).Value = strNAME
                    rng.Offset(2, 2).Value = ws.Cells(cell.Row, intFN1).Value
                    rng.Offset(2, 3).Value = ws.Cells(cell.Row, intLN1).Value
                    rng.Offset(2, 4).Value = ""
                    rng.Offset(2, 5).Value = ""
                    rng.Offset(2, 6).Value = ws.Cells(cell.Row, intST2).Value
                    rng.Offset(2, 7).Value = ws.Cells(cell.Row, intCITY2).Value
                    rng.Offset(2, 8).Value = ws.Cells(cell.Row, intSTATE2).Value
                    rng.Offset(2, 9).Value = ws.Cells(cell.Row, intZIP2).Value
                    
                    rng.Offset(3).Value = cell.Value
                    rng.Offset(3, 1).Value = strNAME
                    rng.Offset(3, 2).Value = ws.Cells(cell.Row, intFN2).Value
                    rng.Offset(3, 3).Value = ws.Cells(cell.Row, intLN2).Value
                    rng.Offset(3, 4).Value = ""
                    rng.Offset(3, 5).Value = ""
                    rng.Offset(3, 6).Value = ws.Cells(cell.Row, intST2).Value
                    rng.Offset(3, 7).Value = ws.Cells(cell.Row, intCITY2).Value
                    rng.Offset(3, 8).Value = ws.Cells(cell.Row, intSTATE2).Value
                    rng.Offset(3, 9).Value = ws.Cells(cell.Row, intZIP2).Value
            End Select
        Next cell
        ws.Range(ws.Cells(1, 1), ws.Cells(intDEL, lngCOL)).EntireRow.Delete
        ws.Range(ws.Cells(1, intFN2), ws.Cells(1, intLN2)).EntireColumn.Delete
        lngROW = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
        lngCOL = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
        Set rng = ws.Range(ws.Cells(1, intBN), ws.Cells(lngROW, lngCOL))
        rng.Select
        rng.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7), Header:=xlYes
        With Application
            .ScreenUpdating = True
            .Calculation = xlCalculationAutomatic
            .DisplayAlerts = True
        End With
    End With
End Sub
 
Upvote 0
Re: Macro Help: Make this Macro Work with more rows?

That's It! Perfect! Thanks so much I could never have done it without you. Well, not this year at least!
 
Upvote 0
You must log in or register to reply here.

Similar threads

G
  • Question
Removing duplicates in a row
Replies
2
Views
531
jae113
J

Forum statistics

Threads
1,214,591
Messages
6,120,424
Members
448,961
Latest member
nzskater

Share this page

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
Back
Top