Convert Excel Range to Rows

[raltam]

Hello,I am trying to figure out a way to create one big master list that lists all of the accounts within the given range.

I have about 1000 rows with different variation of ranges (1st example below) and for each range listed below, I need to list each account within that range in column D and then getting it to do the same for each different range. For example, for my example below, the 1st range is from 70000 to 71000, I want to list all accounts within that range in column D (including the beginning and ending account rage). So for the 1st range, I should ultimately have 1000 rows and continue on for every range there after. If the range is 70000 to 70001 then it would list two object accounts and so on. I think you guys get the point.

At the end I would end up with four columns like in the second example below and will have thousands of rows for the different ranges.

I started doing this manually and trying some IF scenarios, but I haven't been successful and this would obviously take me forever to do it manually.

Any help is greatly appreciated. I did look around and I didn't quite find something that would help me with this, so thanks in advance for your help!!

Key (Col A)	Account From (Col B)	Account To (Col C)
70000 :71000	70000	71000
72000 :74000 <tbody> </tbody>	72000	74000
72000 :74900	72000	74900
Key (A)	Account From (B)	Account To (C)	List Each Account (D)
70000 :71000	70000	71000	70000
70000 :71000	70000	71000	70001
70000 :71000	70000	71000	70002
70000 :71000	70000	71000	70003
70000 :71000	70000	71000	70004
70000 :71000	70000	71000	70005
70000 :71000	70000	71000	70006
70000 :71000	70000	71000	70007
70000 :71000	70000	71000	70008

<tbody>
</tbody>

 

[raltam]

If you want to stick with code just do as it states above, yes I could probably replace the code if I understood where your list of requirements are and how they look on the sheet

I will try this also.... I sent you a PM also. Thank you!

 

[Dryver14]

this splits it out into columns D,E,F and G

Sub KWCreateManyNumbers()




    Dim TopNumber As Long
    Dim BottomNumber As Long
    Dim i As Long
    Dim NextRow As Long
    Dim a As Long
    Dim LastRow As Long
    
    LastRow = Cells(Rows.Count, 2).End(xlUp).Row
    NextRow = Cells(Rows.Count, 7).End(xlUp).Row + 1
    
    For a = 2 To LastRow
        TopNumber = ActiveSheet.Cells(a, 2).Value
        BottomNumber = ActiveSheet.Cells(a, 3).Value
    
        Cells(NextRow, 7).Select
    
        For i = TopNumber To BottomNumber
            Cells(NextRow, 7) = i
            Cells(NextRow, 4) = TopNumber & " " & ":" & " " & BottomNumber
            Cells(NextRow, 5) = TopNumber
            Cells(NextRow, 6) = BottomNumber
            NextRow = NextRow + 1
        Next i
    Next a
    
End Sub

 

[Dryver14]

By the way,

There is no error handling in this procedure. I did notice about 6 lines down on column c you only have 3 digits, the macro would fail if the number is not equal to or more than the previous number

 

[Dryver14]

With some error handling

KWCreateManyNumbers()




    Dim TopNumber As Long
    Dim BottomNumber As Long
    Dim i As Long
    Dim NextRow As Long
    Dim a As Long
    Dim LastRow As Long
    
    LastRow = Cells(Rows.Count, 2).End(xlUp).Row
    NextRow = Cells(Rows.Count, 7).End(xlUp).Row + 1
    
    For a = 2 To LastRow
        TopNumber = ActiveSheet.Cells(a, 2).Value
        BottomNumber = ActiveSheet.Cells(a, 3).Value
    
        Cells(NextRow, 7).Select
        If BottomNumber < TopNumber Then
            BottomNumber = InputBox(Prompt:="TopNumber is " & TopNumber & " Bottomnumber is " & BottomNumber & " Please enter a valid Bottom Number", Title:="Number is less than start number")
        End If
        For i = TopNumber To BottomNumber
            Cells(NextRow, 7) = i
            Cells(NextRow, 4) = TopNumber & " " & ":" & " " & BottomNumber
            Cells(NextRow, 5) = TopNumber
            Cells(NextRow, 6) = BottomNumber
            NextRow = NextRow + 1
        Next i
    Next a
    
End Sub

 

[sheetspread]

Ok I'm looking at the file now. Was this scanned/converted with OCR? Some of the ranges seem off as Dryver14 observed (e.g. 99381 :99331)

 

[raltam]

Ok I'm looking at the file now. Was this scanned/converted with OCR? Some of the ranges seem off as Dryver14 observed (e.g. 99381 :99331)

No. It's an excel file.

 

[raltam]

They will vary.... It's not always 7 series, but most of them will be in the 70000 range..

 

[sheetspread]

There's way too much data for a formula, so I also wrote some code:

Sub expandrange1()
Dim myarray1(), myarray2(), myarray3(), i As Long, j%, x As Long, lr%, diff%
lr = Cells(Rows.Count, 1).End(xlUp).Row
x = 0
For i = 2 To lr
diff = Cells(i, 3) - Cells(i, 2)
For j = 0 To diff
ReDim Preserve myarray1(x)
ReDim Preserve myarray2(x)
myarray1(x) = Cells(i, 1)
myarray2(x) = Cells(i, 2) + j
x = x + 1
Next j
Next i
ReDim myarray3(x, 0)
ReDim myarray3(x, 1)
For i = 0 To UBound(myarray1)
myarray3(i, 0) = myarray1(i)
myarray3(i, 1) = myarray2(i)
Next
Range("e2:f2").Resize(UBound(myarray3) + 1) = myarray3
End Sub

Before running, get rid of the negative differences by adding a column with this formula copied down:

=IF(C2>=B2,C2,B2)

and paste it back to column C

(or if they're not errors but backwards switch them around)

 

[sheetspread]

Shorter code:

Sub expandrange2()
Dim myarray3(), i As Long, j%, x As Long, lr%, diff%, sumdiff As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
sumdiff = Application.Sum(Range("c2").Resize(lr)) - Application.Sum(Range("b2").Resize(lr)) + lr - 1
ReDim myarray3(0 To sumdiff, 0 To 1)
x = 0
For i = 2 To lr
diff = Cells(i, 3) - Cells(i, 2)
For j = 0 To diff
myarray3(x, 0) = Cells(i, 1)
myarray3(x, 1) = Cells(i, 2) + j
x = x + 1
Next j
Next i
Range("e2:f2").Resize(UBound(myarray3) + 1) = myarray3
End Sub

 

[raltam]

There's way too much data for a formula, so I also wrote some code:

Sub expandrange1()
Dim myarray1(), myarray2(), myarray3(), i As Long, j%, x As Long, lr%, diff%
lr = Cells(Rows.Count, 1).End(xlUp).Row
x = 0
For i = 2 To lr
diff = Cells(i, 3) - Cells(i, 2)
For j = 0 To diff
ReDim Preserve myarray1(x)
ReDim Preserve myarray2(x)
myarray1(x) = Cells(i, 1)
myarray2(x) = Cells(i, 2) + j
x = x + 1
Next j
Next i
ReDim myarray3(x, 0)
ReDim myarray3(x, 1)
For i = 0 To UBound(myarray1)
myarray3(i, 0) = myarray1(i)
myarray3(i, 1) = myarray2(i)
Next
Range("e2:f2").Resize(UBound(myarray3) + 1) = myarray3
End Sub

Before running, get rid of the negative differences by adding a column with this formula copied down:

=IF(C2>=B2,C2,B2)

and paste it back to column C

(or if they're not errors but backwards switch them around)

Sheetspread and Dryver14..... You are awesome!!! Thank you soooo much for your help!

I tried it with a few ranges and they both work like a charm!!! Thanks again for your time and help!!!! It looks like I have to run them separate times because I am exceeding 100k rows with the first 245 ranges, but that's a million times better than having to do this manually!!