VBA - Automation for replicating data under certain conditions

C

CleverUserName

New Member
Joined
Nov 25, 2018
Messages
11
view
Hello,
I have various spreadsheets that can contain mailing addresses with anywhere from 60,000 to 140,000 records. On certain records the street address, which is represented in one cell, is listed as a range of home address numbers, such as 145-150 Smith Rd. The City, State and Zip are also in individual cells.
I need some VBA code that will look at each target record in the spreadsheet, determine if it has a range of home address numbers within it and then duplicate the record "X" amount of times but list each home number separately contained in the original range.

EXAMPLE
[TABLE="class: grid, width: 640"]
<tbody>[TR]
[TD]Ad
view
dress[/TD]
[TD]City[/TD]
[TD]State[/TD]
[TD]Zip[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]100-103 Columbia Ave[/TD]
[TD]ABC[/TD]
[TD]NY[/TD]
[TD="align: right"]123456[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[/TR]
[TR]
[TD]9-10 Congress St[/TD]
[TD]ABC[/TD]
[TD]NY[/TD]
[TD="align: right"]123457[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[/TR]
[TR]
[TD]1 N Cutler St[/TD]
[TD]ABC[/TD]
[TD]NY[/TD]
[TD="align: right"]123458[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[/TR]
[TR]
[TD]245- West St[/TD]
[TD]ABC[/TD]
[TD]NY[/TD]
[TD="align: right"]123459[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[/TR]
[TR]
[TD]25A-26B North St[/TD]
[TD]ABC[/TD]
[TD]NY[/TD]
[TD="align: right"]123460[/TD]
[TD]
[/TD]
[TD]
[/TD]
[TD]
[/TD]
[/TR]
[TR]
[TD]-30 Center St[/TD]
[TD]ABC[/TD]
[TD]NY[/TD]
[TD="align: right"]123461[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]RESULT[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Address[/TD]
[TD]City[/TD]
[TD]State[/TD]
[TD]Zip[/TD]
[TD][/TD]
[TD="colspan: 2"]Informational Notes Only[/TD]
[/TR]
[TR]
[TD]100-103 Columbia Ave[/TD]
[TD]ABC[/TD]
[TD]NY[/TD]
[TD="align: right"]123456[/TD]
[TD]
[/TD]
[TD="colspan: 2"]Original Record[/TD]
[/TR]
[TR]
[TD]100 Columbia Ave[/TD]
[TD]ABC[/TD]
[TD]NY[/TD]
[TD="align: right"]123456[/TD]
[TD][/TD]
[TD="colspan: 2"]Dupe Record - Split out[/TD]
[/TR]
[TR]
[TD]101 Columbia Ave[/TD]
[TD]ABC[/TD]
[TD]NY[/TD]
[TD="align: right"]123456[/TD]
[TD][/TD]
[TD="colspan: 2"]Dupe Record - Split out[/TD]
[/TR]
[TR]
[TD]102 Columbia Ave[/TD]
[TD]ABC[/TD]
[TD]NY[/TD]
[TD="align: right"]123456[/TD]
[TD][/TD]
[TD="colspan: 2"]Dupe Record - Split out[/TD]
[/TR]
[TR]
[TD]103 Columbia Ave[/TD]
[TD]ABC[/TD]
[TD]NY[/TD]
[TD="align: right"]123456[/TD]
[TD][/TD]
[TD="colspan: 2"]Dupe Record - Split out[/TD]
[/TR]
[TR]
[TD]9-10 Congress St[/TD]
[TD]ABC[/TD]
[TD]NY[/TD]
[TD="align: right"]123457[/TD]
[TD]
[/TD]
[TD="colspan: 2"]Original Record[/TD]
[/TR]
[TR]
[TD]9 Congress St[/TD]
[TD]ABC[/TD]
[TD]NY[/TD]
[TD="align: right"]123457[/TD]
[TD][/TD]
[TD="colspan: 2"]Dupe Record - Split out[/TD]
[/TR]
[TR]
[TD]10 Congress St[/TD]
[TD]ABC[/TD]
[TD]NY[/TD]
[TD="align: right"]123457[/TD]
[TD][/TD]
[TD="colspan: 2"]Dupe Record - Split out[/TD]
[/TR]
[TR]
[TD]1 N Cutler St[/TD]
[TD]ABC[/TD]
[TD]NY[/TD]
[TD="align: right"]123458[/TD]
[TD][/TD]
[TD="colspan: 2"]Original Record - No Range[/TD]
[/TR]
[TR]
[TD]245- West St[/TD]
[TD]ABC[/TD]
[TD]NY[/TD]
[TD="align: right"]123459[/TD]
[TD]
[/TD]
[TD="colspan: 2"]Original Record - No Range[/TD]
[/TR]
[TR]
[TD]25A-26B North St[/TD]
[TD]ABC[/TD]
[TD]NY[/TD]
[TD="align: right"]123460[/TD]
[TD]
[/TD]
[TD="colspan: 2"]Original Record -Not Numeric Range[/TD]
[/TR]
[TR]
[TD]-30 Center St[/TD]
[TD]ABC[/TD]
[TD]NY[/TD]
[TD="align: right"]123461[/TD]
[TD]
[/TD]
[TD="colspan: 2"]Original Record - No Range[/TD]
[/TR]
</tbody>[/TABLE]

https://drive.google.com/file/d/14If_GHcwF-xZjn8eVArFOSVHegLsxZao/view?usp=sharing
 

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.
Sort by date Sort by votes
is it always strictly in the format with "#-# "? In other words, is the first space always the one after the numbers? Also, do you want the "Informational Notes Only" column output as well?
 
Upvote 0
CleverUserName said:
view
[TABLE="class: grid, width: 640"]
<tbody>[TR]
[TD]25A-26B North St[/TD]
[TD]ABC[/TD]
[TD]NY[/TD]
[TD="align: right"]123460[/TD]
[TD]
[/TD]
[TD="colspan: 2"]Original Record -Not Numeric Range[/TD]
[/TR]
</tbody>[/TABLE]
Click to expand...
Could the above have been this instead and, if so, would it be split out or not?

25A-26A North St.
 
Upvote 0
The format could be "#-#", or "#-", or "-#", or "#" or some combination of an alphanumeric format such as "#@-#@" or "@#-@#". Out of all of these only the first one in Red would be a valid one to try and split up.
Yes, the first space is always after the number(s)
No, I do not want the Informational notes only column as output as well. It was simply meant to help describe better what was happening in the results table.
Thank you.
 
Upvote 0
CleverUserName said:
The format could be "#-#", or "#-", or "-#", or "#" or some combination of an alphanumeric format such as "#@-#@" or "@#-@#". Out of all of these only the first one in Red would be a valid one to try and split up.
Yes, the first space is always after the number(s)
No, I do not want the Informational notes only column as output as well. It was simply meant to help describe better what was happening in the results table.
Thank you.
Click to expand...

Try this:

Code: 
Sub FindReplace()
Dim Arr As Variant
Dim AddArr() As String
Dim sAdd As String, sNum As String, sStreet As String
Dim iNum1 As Long, iNum2 As Long
Dim i As Long, nRng As Integer
Dim wb As Workbook, ws As Worksheet

Set wb = ActiveWorkbook
Set ws = ActiveSheet

With ws
    Arr = .UsedRange.Value2

    For i = UBound(Arr) To 2 Step -1
        sAdd = Arr(i, 1)
        AddArr = Split(sAdd, " ", 2)
        
        sNum = AddArr(0)
        sStreet = " " & AddArr(1)
        nRng = InStr(1, sNum, "-", 1)
    
        If nRng <> 0 Then
            If IsNumeric(Left(sNum, nRng - 1)) And IsNumeric(Mid(sNum, nRng + 1, Len(sNum))) Then
                iNum1 = Left(sNum, nRng - 1)
                iNum2 = Mid(sNum, nRng + 1, Len(sNum))
                    Do Until iNum2 = iNum1 - 1
                        .Rows(i + 1).Insert
                        .Cells(i + 1, 1) = iNum2 & sStreet
                        .Range(.Cells(i + 1, 2), .Cells(i + 1, 4)) = .Range(.Cells(i, 2), .Cells(i, 4)).Value2
                        iNum2 = iNum2 - 1
                    Loop
            End If
        End If
    Next i
End With
End Sub
 
Upvote 0
Here is another macro that you can consider...
Code: 
[table="width: 500"]
[tr]
	[td]Sub ExpandNumberRanges()
  Dim R As Long, Txt As String, Nums() As String
  For R = 2 To Cells(Rows.Count, "A").End(xlUp).Row
    Txt = Cells(R, "A").Value
    If Not Txt Like "[!0-9-]" And Txt Like "*#-#*" Then
      Nums = Split(Split(Txt)(0), "-")
      Rows(R + 1).Resize(Nums(1) - Nums(0) + 1).Insert
      Cells(R + 1, "A").Resize(Nums(1) - Nums(0) + 1) = Evaluate("ROW(" & Nums(0) & ":" & Nums(1) & ")&""" & Mid(Txt, InStr(Txt, " ")) & """")
    End If
  Next
  With Range("B2:D" & Cells(Rows.Count, "A").End(xlUp).Row)
    .SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
    .Value = .Value
  End With
End Sub[/td]
[/tr]
[/table]
 
Upvote 0
Rick Rothstein said:
Here is another macro that you can consider...
Code: 
[table="width: 500"]
[tr]
	[td]Sub ExpandNumberRanges()
  Dim R As Long, Txt As String, Nums() As String
  For R = 2 To Cells(Rows.Count, "A").End(xlUp).Row
    Txt = Cells(R, "A").Value
    If Not Txt Like "[!0-9-]" And Txt Like "*#-#*" Then
      Nums = Split(Split(Txt)(0), "-")
      Rows(R + 1).Resize(Nums(1) - Nums(0) + 1).Insert
      Cells(R + 1, "A").Resize(Nums(1) - Nums(0) + 1) = Evaluate("ROW(" & Nums(0) & ":" & Nums(1) & ")&""" & Mid(Txt, InStr(Txt, " ")) & """")
    End If
  Next
  With Range("B2:D" & Cells(Rows.Count, "A").End(xlUp).Row)
    .SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
    .Value = .Value
  End With
End Sub[/td]
[/tr]
[/table]
Click to expand...

Much more concise than mine for sure.
 
Upvote 0
BAlGaInTl said:
Try this:

Code: 
Sub FindReplace()
Dim Arr As Variant
Dim AddArr() As String
Dim sAdd As String, sNum As String, sStreet As String
Dim iNum1 As Long, iNum2 As Long
Dim i As Long, nRng As Integer
Dim wb As Workbook, ws As Worksheet

Set wb = ActiveWorkbook
Set ws = ActiveSheet

With ws
    Arr = .UsedRange.Value2

    For i = UBound(Arr) To 2 Step -1
        sAdd = Arr(i, 1)
        AddArr = Split(sAdd, " ", 2)
        
        sNum = AddArr(0)
        sStreet = " " & AddArr(1)
        nRng = InStr(1, sNum, "-", 1)
    
        If nRng <> 0 Then
            If IsNumeric(Left(sNum, nRng - 1)) And IsNumeric(Mid(sNum, nRng + 1, Len(sNum))) Then
                iNum1 = Left(sNum, nRng - 1)
                iNum2 = Mid(sNum, nRng + 1, Len(sNum))
                    Do Until iNum2 = iNum1 - 1
                        .Rows(i + 1).Insert
                        .Cells(i + 1, 1) = iNum2 & sStreet
                        .Range(.Cells(i + 1, 2), .Cells(i + 1, 4)) = .Range(.Cells(i, 2), .Cells(i, 4)).Value2
                        iNum2 = iNum2 - 1
                    Loop
            End If
        End If
    Next i
End With
End Sub
Click to expand...


Thank you. I tried this code on about 30,000 records and excel was indicating that it was not responding. I'll get this when I run large procedures, but it typically recovers. I let your code run for 10 minutes and then tried to [ctl]+[Break] to stop, but could not. So I had to end excel via the task manager.
 
Upvote 0
Rick Rothstein said:
Here is another macro that you can consider...
Code: 
[TABLE="width: 500"]
<tbody>[TR]
[TD]Sub ExpandNumberRanges()
  Dim R As Long, Txt As String, Nums() As String
  For R = 2 To Cells(Rows.Count, "A").End(xlUp).Row
    Txt = Cells(R, "A").Value
    If Not Txt Like "[!0-9-]" And Txt Like "*#-#*" Then
      Nums = Split(Split(Txt)(0), "-")
      Rows(R + 1).Resize(Nums(1) - Nums(0) + 1).Insert
      Cells(R + 1, "A").Resize(Nums(1) - Nums(0) + 1) = Evaluate("ROW(" & Nums(0) & ":" & Nums(1) & ")&""" & Mid(Txt, InStr(Txt, " ")) & """")
    End If
  Next
  With Range("B2:D" & Cells(Rows.Count, "A").End(xlUp).Row)
    .SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
    .Value = .Value
  End With
End Sub[/TD]
[/TR]
</tbody>[/TABLE]
Click to expand...

Thank you for this code. Very elegant. I did try this on about 30,000 records and keep getting an error when R = 5697. Error reads Subscript out of range. I think it is referring to "Nums(1)".
Also, is there a way to copy down CITY,STATE,ZIP data when splitting the record?
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Solved
Macro to Copy Cell Adjacent in One Sheet and Paste in Another Sheet
Replies
1
Views
449
mumps
mumps
K
  • Question Question
help with vba code to match data on multiple worksheets
Replies
3
Views
2K
mumps
mumps
N
  • Question Question
Finding data points in a row based on condition & then pasting it
Replies
1
Views
460
Naveen Gaur
N

Forum statistics

Threads
1,224,823
Messages
6,181,170
Members
453,021
Latest member
Justyna P

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