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: [TABLE="width: 1382"]
<tbody>[TR]
[TD="colspan: 4"]
  • Copy each Row with that has data in column E, paste value in first empty row
[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="colspan: 4"]
  • For each of those Duplicated Rows, Copy data from E:F and overwrite values in C:D
[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="colspan: 4"]
  • Delete Columns E:F (Because Both Names are now in Columns C:D instead)
[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="colspan: 4"]
  • Duplicate all Rows (Except for header row) and paste below in first empty row
[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="colspan: 4"]
  • For each duplicated row, copy data from I:L and overwrite the values in E:H
[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="colspan: 4"]
  • Delete Columns I:L (because both addresses are now in columns E:H instead)
[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="colspan: 2"]
  • Sort Column A in ascending order
[/TD]
[TD][/TD]
[TD="colspan: 2"][/TD]
[/TR]
[TR]
[TD="colspan: 3"]
  • 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
[/TD]
[TD="colspan: 2"][/TD]
[/TR]
</tbody>[/TABLE]

Example RAW data (Before macro):

[TABLE="class: tableizer-table"]
<tbody>[TR="class: tableizer-firstrow"]
[TH]ID#[/TH]
[TH]BOTH-Names[/TH]
[TH]First[/TH]
[TH]Last[/TH]
[TH]First2[/TH]
[TH]Last2[/TH]
[TH]Street[/TH]
[TH]City[/TH]
[TH]State[/TH]
[TH]Zip[/TH]
[TH]StreetB[/TH]
[TH]CityB[/TH]
[TH]StateB[/TH]
[TH]ZipB[/TH]
[/TR]
[TR]
[TD]ABC123[/TD]
[TD]Thomas Joneses[/TD]
[TD]Thomas[/TD]
[TD]Joneses[/TD]
[TD][/TD]
[TD][/TD]
[TD]1151 Glenhurst Ave[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50916[/TD]
[TD]8189 CHRISTIAN CT APT 893[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50922[/TD]
[/TR]
[TR]
[TD]ABC124[/TD]
[TD]Fidel & Maria Smartie[/TD]
[TD]Fidel[/TD]
[TD]Smartie[/TD]
[TD]Maria[/TD]
[TD]Smartie[/TD]
[TD]5991 Braidwood Dr[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50919[/TD]
[TD]5991 BRAIDWOOD DR[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50919[/TD]
[/TR]
[TR]
[TD]ABC125[/TD]
[TD]Jackie & Christina Spitter[/TD]
[TD]Jackie[/TD]
[TD]Spitter[/TD]
[TD]Christina[/TD]
[TD]Spitter[/TD]
[TD]5718 Midnight Ln[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50929[/TD]
[TD]5718 MIDNIGHT LN[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50929[/TD]
[/TR]
[TR]
[TD]ABC126[/TD]
[TD]Donald Lulu[/TD]
[TD]Donald[/TD]
[TD]Lulu[/TD]
[TD][/TD]
[TD][/TD]
[TD]9118 Galene Dr[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50999[/TD]
[TD]9118 GALENE DR[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50999[/TD]
[/TR]
[TR]
[TD]ABC127[/TD]
[TD]George & Dorothy Hard[/TD]
[TD]George[/TD]
[TD]Hard[/TD]
[TD]Dorothy[/TD]
[TD]Hard[/TD]
[TD]1811 Libby Ln[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50972[/TD]
[TD]7816 RUTLEDGE RD[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50958[/TD]
[/TR]
[TR]
[TD]ABC128[/TD]
[TD]Samantha Davenport[/TD]
[TD]Samantha[/TD]
[TD]Davenport[/TD]
[TD][/TD]
[TD][/TD]
[TD]7919 Black Walnut Cir[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50929[/TD]
[TD]7919 BLACK WALNUT CIR[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50929[/TD]
[/TR]
[TR]
[TD]ABC129[/TD]
[TD]Jackie Katnip[/TD]
[TD]Jackie[/TD]
[TD]Katnip[/TD]
[TD][/TD]
[TD][/TD]
[TD]3399 Ethelwood Dr[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50999[/TD]
[TD]3399 ETHELWOOD DR[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50999[/TD]
[/TR]
[TR]
[TD]ABC130[/TD]
[TD]Mary Smithie[/TD]
[TD]Mary[/TD]
[TD]Smithie[/TD]
[TD][/TD]
[TD][/TD]
[TD]8985 Dogoon Dr[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50923[/TD]
[TD]8985 DOGOON DR[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50923[/TD]
[/TR]
[TR]
[TD]ABC131[/TD]
[TD]Wanda Chef[/TD]
[TD]Wanda[/TD]
[TD]Chef[/TD]
[TD][/TD]
[TD][/TD]
[TD]6817 Carolina Ave[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50958[/TD]
[TD]7691 NANCY LN[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50958[/TD]
[/TR]
[TR]
[TD]ABC132[/TD]
[TD]Antoine Who[/TD]
[TD]Antoine[/TD]
[TD]Who[/TD]
[TD][/TD]
[TD][/TD]
[TD]939 Francis Ave[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50914[/TD]
[TD]939 E FRANCIS AVE APT 8[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50914[/TD]
[/TR]
[TR]
[TD]ABC133[/TD]
[TD]Joshua Reeves[/TD]
[TD]Joshua[/TD]
[TD]Reeves[/TD]
[TD][/TD]
[TD][/TD]
[TD]1698 Kerrick Ln[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50958[/TD]
[TD]7319 AUSTINWOOD RD[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50914[/TD]
[/TR]
[TR]
[TD]ABC134[/TD]
[TD]Zachariah & Brittany Soup[/TD]
[TD]Zachariah[/TD]
[TD]Soup[/TD]
[TD]Brittany[/TD]
[TD]Soup[/TD]
[TD]6118 Highgrade Dr[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50991[/TD]
[TD]6118 HIGHGRADE DR[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50991[/TD]
[/TR]
[TR]
[TD]ABC135[/TD]
[TD]Clyda Green[/TD]
[TD]Clyda[/TD]
[TD]Green[/TD]
[TD][/TD]
[TD][/TD]
[TD]889 Mcbroom Dr[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50914[/TD]
[TD]889 MCBROOM DR[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50914[/TD]
[/TR]
[TR]
[TD]ABC136[/TD]
[TD]Latoscia Civil[/TD]
[TD]Latoscia[/TD]
[TD]Civil[/TD]
[TD][/TD]
[TD][/TD]
[TD]7189 Spring Run Dr[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50991[/TD]
[TD]7189 SPRING RUN DR[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50991[/TD]
[/TR]
[TR]
[TD]ABC137[/TD]
[TD]Thomas Tomtom[/TD]
[TD]Thomas[/TD]
[TD]Tomtom[/TD]
[TD][/TD]
[TD][/TD]
[TD]898 S Keats Ave[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50906[/TD]
[TD]898 S KEATS AVE[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50906[/TD]
[/TR]
[TR]
[TD]ABC138[/TD]
[TD]Ju & Jeron Great[/TD]
[TD]Ju[/TD]
[TD]Great[/TD]
[TD]Jeron[/TD]
[TD]Great[/TD]
[TD]9191 Walter Ave[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50915[/TD]
[TD]9191 WALTER AVE[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50915[/TD]
[/TR]
[TR]
[TD]ABC139[/TD]
[TD]Robt & Mary Salmon[/TD]
[TD]Robt[/TD]
[TD]Salmon[/TD]
[TD]Mary[/TD]
[TD]Salmon[/TD]
[TD]883 Marytena Dr[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50914[/TD]
[TD]883 MARYTENA DR[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50914[/TD]
[/TR]
</tbody>[/TABLE]


Example of what data should look like AFTER macro:


[TABLE="class: tableizer-table"]
<tbody>[TR="class: tableizer-firstrow"]
[TH]ID#[/TH]
[TH]BOTH-Names[/TH]
[TH]First[/TH]
[TH]Last[/TH]
[TH]Street[/TH]
[TH]City[/TH]
[TH]State[/TH]
[TH]Zip[/TH]
[/TR]
[TR]
[TD]ABC123[/TD]
[TD]Thomas Joneses[/TD]
[TD]Thomas[/TD]
[TD]Joneses[/TD]
[TD]1151 Glenhurst Ave[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50916[/TD]
[/TR]
[TR]
[TD]ABC123[/TD]
[TD]Thomas Joneses[/TD]
[TD]Thomas[/TD]
[TD]Joneses[/TD]
[TD]8189 CHRISTIAN CT APT 893[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50922[/TD]
[/TR]
[TR]
[TD]ABC124[/TD]
[TD]Fidel & Maria Smartie[/TD]
[TD]Fidel[/TD]
[TD]Smartie[/TD]
[TD]5991 Braidwood Dr[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50919[/TD]
[/TR]
[TR]
[TD]ABC124[/TD]
[TD]Fidel & Maria Smartie[/TD]
[TD]Maria[/TD]
[TD]Smartie[/TD]
[TD]5991 Braidwood Dr[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50919[/TD]
[/TR]
[TR]
[TD]ABC125[/TD]
[TD]Jackie & Christina Spitter[/TD]
[TD]Jackie[/TD]
[TD]Spitter[/TD]
[TD]5718 Midnight Ln[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50929[/TD]
[/TR]
[TR]
[TD]ABC125[/TD]
[TD]Jackie & Christina Spitter[/TD]
[TD]Christina[/TD]
[TD]Spitter[/TD]
[TD]5718 Midnight Ln[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50929[/TD]
[/TR]
[TR]
[TD]ABC126[/TD]
[TD]Donald Lulu[/TD]
[TD]Donald[/TD]
[TD]Lulu[/TD]
[TD]9118 Galene Dr[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50999[/TD]
[/TR]
[TR]
[TD]ABC127[/TD]
[TD]George & Dorothy Hard[/TD]
[TD]George[/TD]
[TD]Hard[/TD]
[TD]1811 Libby Ln[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50972[/TD]
[/TR]
[TR]
[TD]ABC127[/TD]
[TD]George & Dorothy Hard[/TD]
[TD]Dorothy[/TD]
[TD]Hard[/TD]
[TD]1811 Libby Ln[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50972[/TD]
[/TR]
[TR]
[TD]ABC127[/TD]
[TD]George & Dorothy Hard[/TD]
[TD]George[/TD]
[TD]Hard[/TD]
[TD]7816 RUTLEDGE RD[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50958[/TD]
[/TR]
[TR]
[TD]ABC127[/TD]
[TD]George & Dorothy Hard[/TD]
[TD]Dorothy[/TD]
[TD]Hard[/TD]
[TD]7816 RUTLEDGE RD[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50958[/TD]
[/TR]
[TR]
[TD]ABC128[/TD]
[TD]Samantha Davenport[/TD]
[TD]Samantha[/TD]
[TD]Davenport[/TD]
[TD]7919 Black Walnut Cir[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50929[/TD]
[/TR]
[TR]
[TD]ABC129[/TD]
[TD]Jackie Katnip[/TD]
[TD]Jackie[/TD]
[TD]Katnip[/TD]
[TD]3399 Ethelwood Dr[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50999[/TD]
[/TR]
[TR]
[TD]ABC130[/TD]
[TD]Mary Smithie[/TD]
[TD]Mary[/TD]
[TD]Smithie[/TD]
[TD]8985 Dogoon Dr[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50923[/TD]
[/TR]
[TR]
[TD]ABC131[/TD]
[TD]Wanda Chef[/TD]
[TD]Wanda[/TD]
[TD]Chef[/TD]
[TD]6817 Carolina Ave[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50958[/TD]
[/TR]
[TR]
[TD]ABC131[/TD]
[TD]Wanda Chef[/TD]
[TD]Wanda[/TD]
[TD]Chef[/TD]
[TD]7691 NANCY LN[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50958[/TD]
[/TR]
[TR]
[TD]ABC132[/TD]
[TD]Antoine Who[/TD]
[TD]Antoine[/TD]
[TD]Who[/TD]
[TD]939 Francis Ave[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50914[/TD]
[/TR]
[TR]
[TD]ABC132[/TD]
[TD]Antoine Who[/TD]
[TD]Antoine[/TD]
[TD]Who[/TD]
[TD]939 E FRANCIS AVE APT 8[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50914[/TD]
[/TR]
[TR]
[TD]ABC133[/TD]
[TD]Joshua Reeves[/TD]
[TD]Joshua[/TD]
[TD]Reeves[/TD]
[TD]1698 Kerrick Ln[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50958[/TD]
[/TR]
[TR]
[TD]ABC133[/TD]
[TD]Joshua Reeves[/TD]
[TD]Joshua[/TD]
[TD]Reeves[/TD]
[TD]7319 AUSTINWOOD RD[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50914[/TD]
[/TR]
[TR]
[TD]ABC134[/TD]
[TD]Zachariah & Brittany Soup[/TD]
[TD]Zachariah[/TD]
[TD]Soup[/TD]
[TD]6118 Highgrade Dr[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50991[/TD]
[/TR]
[TR]
[TD]ABC134[/TD]
[TD]Zachariah & Brittany Soup[/TD]
[TD]Brittany[/TD]
[TD]Soup[/TD]
[TD]6118 Highgrade Dr[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50991[/TD]
[/TR]
[TR]
[TD]ABC135[/TD]
[TD]Clyda Green[/TD]
[TD]Clyda[/TD]
[TD]Green[/TD]
[TD]889 Mcbroom Dr[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50914[/TD]
[/TR]
[TR]
[TD]ABC136[/TD]
[TD]Latoscia Civil[/TD]
[TD]Latoscia[/TD]
[TD]Civil[/TD]
[TD]7189 Spring Run Dr[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50991[/TD]
[/TR]
[TR]
[TD]ABC137[/TD]
[TD]Thomas Tomtom[/TD]
[TD]Thomas[/TD]
[TD]Tomtom[/TD]
[TD]898 S Keats Ave[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50906[/TD]
[/TR]
[TR]
[TD]ABC138[/TD]
[TD]Ju & Jeron Great[/TD]
[TD]Ju[/TD]
[TD]Great[/TD]
[TD]9191 Walter Ave[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50915[/TD]
[/TR]
[TR]
[TD]ABC138[/TD]
[TD]Ju & Jeron Great[/TD]
[TD]Jeron[/TD]
[TD]Great[/TD]
[TD]9191 Walter Ave[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50915[/TD]
[/TR]
[TR]
[TD]ABC139[/TD]
[TD]Robt & Mary Salmon[/TD]
[TD]Robt[/TD]
[TD]Salmon[/TD]
[TD]883 Marytena Dr[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50914[/TD]
[/TR]
[TR]
[TD]ABC139[/TD]
[TD]Robt & Mary Salmon[/TD]
[TD]Mary[/TD]
[TD]Salmon[/TD]
[TD]883 Marytena Dr[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50914[/TD]
[/TR]
</tbody>[/TABLE]


(Note that a link to a file with all the example data can be found above)
 
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:

[TABLE="class: tableizer-table"]
<thead>[TR="class: tableizer-firstrow"]
[TH]ID#[/TH]
[TH]BOTH-Names[/TH]
[TH]First[/TH]
[TH]Last[/TH]
[TH]First2[/TH]
[TH]Last2[/TH]
[TH]Street[/TH]
[TH]City[/TH]
[TH]State[/TH]
[TH]Zip[/TH]
[TH]StreetB[/TH]
[TH]CityB[/TH]
[TH]StateB[/TH]
[TH]ZipB[/TH]
[/TR]
</thead><tbody> [TR]
[TD]ABC127[/TD]
[TD]George & Dorothy Hard[/TD]
[TD]George[/TD]
[TD]Hard[/TD]
[TD]Dorothy[/TD]
[TD]Hard[/TD]
[TD]1811 Libby Ln[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50972[/TD]
[TD]7816 RUTLEDGE RD[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50958[/TD]
[/TR]
</tbody>[/TABLE]

Turns into:

[TABLE="class: tableizer-table"]
<thead>[TR="class: tableizer-firstrow"]
[TH]ID#[/TH]
[TH]BOTH-Names[/TH]
[TH]First[/TH]
[TH]Last[/TH]
[TH]Street[/TH]
[TH]City[/TH]
[TH]State[/TH]
[TH]Zip[/TH]
[/TR]
</thead><tbody> [TR]
[TD]ABC127[/TD]
[TD]George & Dorothy Hard[/TD]
[TD]George[/TD]
[TD]Hard[/TD]
[TD]1811 Libby Ln[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50972[/TD]
[/TR]
[TR]
[TD]ABC127[/TD]
[TD]George & Dorothy Hard[/TD]
[TD]Dorothy[/TD]
[TD]Hard[/TD]
[TD]1811 Libby Ln[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50972[/TD]
[/TR]
[TR]
[TD]ABC127[/TD]
[TD]George & Dorothy Hard[/TD]
[TD]George[/TD]
[TD]Hard[/TD]
[TD]7816 RUTLEDGE RD[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50958[/TD]
[/TR]
[TR]
[TD]ABC127[/TD]
[TD]George & Dorothy Hard[/TD]
[TD]Dorothy[/TD]
[TD]Hard[/TD]
[TD]7816 RUTLEDGE RD[/TD]
[TD]Shepherds[/TD]
[TD]NC[/TD]
[TD]50958[/TD]
[/TR]
</tbody>[/TABLE]


(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 Question
Removing duplicates in a row
Replies
2
Views
608
jae113
J

Forum statistics

Threads
1,226,898
Messages
6,193,563
Members
453,807
Latest member
PKruger

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