VBA - Automation for replicating data under certain conditions

[CleverUserName]

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

Ad dress	City	State	Zip
100-103 Columbia Ave	ABC	NY	123456
9-10 Congress St	ABC	NY	123457
1 N Cutler St	ABC	NY	123458
245- West St	ABC	NY	123459
25A-26B North St	ABC	NY	123460
-30 Center St	ABC	NY	123461
RESULT
Address	City	State	Zip		Informational Notes Only
100-103 Columbia Ave	ABC	NY	123456		Original Record
100 Columbia Ave	ABC	NY	123456		Dupe Record - Split out
101 Columbia Ave	ABC	NY	123456		Dupe Record - Split out
102 Columbia Ave	ABC	NY	123456		Dupe Record - Split out
103 Columbia Ave	ABC	NY	123456		Dupe Record - Split out
9-10 Congress St	ABC	NY	123457		Original Record
9 Congress St	ABC	NY	123457		Dupe Record - Split out
10 Congress St	ABC	NY	123457		Dupe Record - Split out
1 N Cutler St	ABC	NY	123458		Original Record - No Range
245- West St	ABC	NY	123459		Original Record - No Range
25A-26B North St	ABC	NY	123460		Original Record -Not Numeric Range
-30 Center St	ABC	NY	123461		Original Record - No Range

<tbody>
</tbody>

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

 

[CleverUserName]

Apologies, I just realized that you do handle the copying of CITY,STATE,ZIP. I just did not see it as that part of the code did not execute due to the error received

 

[BAlGaInTl]

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.

I tried to re-write it do do more in arrays. I'm still learning them. It's not as concise as the previous code, but you can try this. I've created separate input and output sheets so that you can compare the results. You'll need to update those with your address input sheet name, and create a blank sheet called "Output". It could be modified to write over the original once you are sure it's working.

Sub FindReplace()
Dim Arr As Variant
Dim AddArr() As String, OutArr() As String, OutArrTrans As Variant
Dim sAdd As String, sNum As String, sStreet As String
Dim sCity As String, sState As String, sZip As String
Dim iNum1 As Long, iNum2 As Long
Dim i As Long, j As Long, n As Long, nRng As Integer
Dim wb As Workbook, wsIn As Worksheet, wsOut As Worksheet
Dim rOut As Range

Set wb = ActiveWorkbook
Set wsIn = wb.Worksheets("Input") 'input sheet
Set wsOut = wb.Worksheets("Output") 'output sheet


Arr = wsIn.UsedRange.Value2

ReDim OutArr(0)
OutArr(0) = "Address|City|State|Zip"

j = 0
    For i = 2 To UBound(Arr)
        
        sAdd = Arr(i, 1)
        AddArr = Split(sAdd, " ", 2)
        sNum = AddArr(0)
        sStreet = " " & AddArr(1)
        sCity = Arr(i, 2)
        sState = Arr(i, 3)
        sZip = Arr(i, 4)
        n = UBound(OutArr) + 1
        ReDim Preserve OutArr(n)
        OutArr(n) = sAdd & "|" & sCity & "|" & sState & "|" & sZip
        
        nRng = InStr(1, sNum, "-", 1)
        If nRng <> 0 Then
            If IsNumeric(Left(sNum, nRng - 1)) And IsNumeric(Mid(sNum, nRng + 1, Len(sNum))) Then
                j = n + 1
                iNum1 = Left(sNum, nRng - 1)
                iNum2 = Mid(sNum, nRng + 1, Len(sNum))
                    Do Until iNum1 = iNum2 + 1
                        ReDim Preserve OutArr(j)
                        OutArr(j) = iNum1 & sStreet & "|" & sCity & "|" & sState & "|" & sZip
                        
                        iNum1 = iNum1 + 1
                        j = j + 1
                    Loop
            End If
        End If
    Next i
OutArrTrans = Application.Transpose(OutArr)
n = UBound(OutArr) + 1
With wsOut
    Set rOut = .Range(.Cells(1, 1), .Cells(n, 1))
End With
rOut = OutArrTrans
rOut.TextToColumns Destination:=Range("A1"), Other:=True, OtherChar:="|"
End Sub

 

[Rick Rothstein]

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)".

When the error occurs at R = 5697, what does the Txt variable have in it?

Also, what version of Excel are you using?

 

[CleverUserName]

When the error occurs at R = 5697, what does the Txt variable have in it?

Also, what version of Excel are you using?

At the error point Txt = "128 Norman Rd 1-4"
I am using Excel 365.

 

[BAlGaInTl]

At the error point Txt = "128 Norman Rd 1-4"
I am using Excel 365.

Most likely because of the "1-4"

I was leary of hyphens other places in the street address which is why I went a different route and split after the first space. My new code should work, but maybe Rick can fix his as well. That code is a bit above my head.

 

[Rick Rothstein]

Most likely because of the "1-4"

My code is not bothered by this (it ignores it).

 

[CleverUserName]

While I was trying to run the new code that BAlGaInTl posted, I kept running into the same issue with Exel not responding. After looking at the 30K line data set I was testing with I found 2 additional scenarios.
1. "#-#-"
2. "#,#" In this scenario, the second number in red was smaller than the first.

After removing these scenarios, both codes executed. I can certainly try and modify these manually, but if these scenarios could be included, I would be most grateful.

Mr. Rothstein, I believe your code stops executing when "R" reaches Cells(Rows.Count, "A").End(xlUp).Row. However, due to the fact that we are expanding the number of rows by inserting the values after we split up an address with a range, the spreadsheet row numbers continue to grow and therefore only part of the data gets reviewed and modified. Am I right in this interpretation?

 

[CleverUserName]

While I was trying to run the new code that BAlGaInTl posted, I kept running into the same issue with Exel not responding. After looking at the 30K line data set I was testing with I found 2 additional scenarios.
1. "#-#-"
2. "#,#" In this scenario, the second number in red was smaller than the first.

After removing these scenarios, both codes executed. I can certainly try and modify these manually, but if these scenarios could be included, I would be most grateful.

Mr. Rothstein, I believe your code stops executing when "R" reaches Cells(Rows.Count, "A").End(xlUp).Row. However, due to the fact that we are expanding the number of rows by inserting the values after we split up an address with a range, the spreadsheet row numbers continue to grow and therefore only part of the data gets reviewed and modified. Am I right in this interpretation?

Scenario 1 above should be included and split up
Scenario 2 should be ignored
Thank you.

 

[BAlGaInTl]

While I was trying to run the new code that BAlGaInTl posted, I kept running into the same issue with Exel not responding. After looking at the 30K line data set I was testing with I found 2 additional scenarios.
1. "#-#-"
2. "#,#" In this scenario, the second number in red was smaller than the first.

After removing these scenarios, both codes executed. I can certainly try and modify these manually, but if these scenarios could be included, I would be most grateful.

Mr. Rothstein, I believe your code stops executing when "R" reaches Cells(Rows.Count, "A").End(xlUp).Row. However, due to the fact that we are expanding the number of rows by inserting the values after we split up an address with a range, the spreadsheet row numbers continue to grow and therefore only part of the data gets reviewed and modified. Am I right in this interpretation?

On Rick's code, try changing

For R = 2 To Cells(Rows.Count, "A").End(xlUp).Row

to

For R = Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1

I don't know if that will work or not, but it will add the rows backwards.