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

 

[BAlGaInTl]

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?

 

[Rick Rothstein]

25A-26B North St

ABC

NY

123460

Original Record -Not Numeric Range

<tbody>
</tbody>

Could the above have been this instead and, if so, would it be split out or not?

25A-26A North St.

 

[CleverUserName]

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.

 

[CleverUserName]

No sir. It would not be split out as it is an alphanumeric and not a valid number for these purposes.

 

[BAlGaInTl]

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.

Try this:

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

 

[Rick Rothstein]

Here is another macro that you can consider...

[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]

 

[BAlGaInTl]

Here is another macro that you can consider...

[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]

Much more concise than mine for sure.

 

[CleverUserName]

Try this:

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

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.

 

[CleverUserName]

Here is another macro that you can consider...

[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]

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?