Find values in range and print to column

Question

How can I generate the Excel as in the image below via a macro? Briefly I would like to make:

• numbers between a1 and b1 print to d column;
• numbers between a2 and b2 print to e column;
• numbers between a3 and b3 print to f column.

Columns A and B have thousands of values.

Answer 1

As an alternative, here is a formula solution:

=IF(ROW(D1)>INDEX($A:$B,COLUMN(D1)-COLUMN($C1),2)-INDEX($A:$B,COLUMN(D1)-COLUMN($C1),1)+1,"",INDEX($A:$B,COLUMN(D1)-COLUMN($C1),1)+ROW(D1)-1)

Though I realize that a formula solution may not be feasible based on this statement:

Columns A and B have thousands of values.

EDIT: Pure array VBA solution:

Sub tgr()

    Dim ws As Worksheet
    Dim rData As Range
    Dim aData As Variant
    Dim aResults() As Variant
    Dim lMaxDiff As Long
    Dim i As Long, j As Long
    Dim rIndex As Long, cIndex As Long

    Set ws = ActiveWorkbook.ActiveSheet
    Set rData = ws.Range("A1", ws.Cells(Rows.Count, "B").End(xlUp))

    lMaxDiff = Evaluate("MAX(" & rData.Columns(2).Address(external:=True) & "-" & rData.Columns(1).Address(external:=True) & ")") + 1
    aData = rData.Value2
    ReDim aResults(1 To lMaxDiff, 1 To rData.Rows.Count)

    For i = LBound(aData, 1) To UBound(aData, 1)
        If IsNumeric(aData(i, 1)) And IsNumeric(aData(i, 2)) Then
            rIndex = 0
            cIndex = cIndex + 1
            For j = Int(aData(i, 1)) To Int(aData(i, 2))
                rIndex = rIndex + 1
                aResults(rIndex, cIndex) = j
            Next j
        End If
    Next i

    ws.Range("D1").Resize(UBound(aResults, 1), UBound(aResults, 2)).Value = aResults

End Sub

Answer 2

Here's another quick one just for fun:

Sub transposeNfill()
Dim lastRow&, i&, xStart$, xEnd$, xMid$

lastRow = Cells(Rows.Count, 1).End(xlUp).Row

For i = 1 To lastRow
    xStart = Cells(i, 1)
    xEnd = Cells(i, 2)
    xMid = xEnd - xStart
    Cells(1, i + 3).Value = xStart
    Cells(1 + xMid, i + 3) = xEnd
    Range(Cells(2, i + 3), Cells(xMid, i + 3)).FormulaR1C1 = "=r[-1]c+1"
    Cells.Copy
    Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False

Next i

End Sub

Answer 3

You could use this:

 Sub test()

Dim Lastrow As Long
Dim j As Double, i As Double, r As Double
Dim wb As Workbook
Dim ws As Worksheet

Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1") ' Change the name of your sheet

Lastrow = ws.Range("A" & Rows.Count).End(xlUp).Row

j = 4 ' Column D

With ws

For i = 1 To Lastrow ' Start the loop at A1 until the last row in column A

    .Cells(1, j) = .Cells(i, 1).Value

r = 1

    Do
        .Cells(r + 1, j) = .Cells(r, j) + 1
        r = r + 1

    Loop Until .Cells(r, j) = .Cells(i, 2).Value

    j = j + 1

Next i

End With

End Sub

Answer 4

I like puzzles too.

Sub from_here_to_there()
    Dim rw As Long
    With Worksheets("Sheet5")  '<~~ set this worksheet properly!
        For rw = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
            If IsNumeric(.Cells(rw, 1)) And IsNumeric(.Cells(rw, 2)) Then
                With .Columns(Application.Max(4, .Cells(1, Columns.Count).End(xlToLeft).Column + 1))
                    .Cells(1, 1) = .Parent.Cells(rw, 1).Value2
                    .DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
                        Step:=1, Stop:=.Parent.Cells(rw, 2).Value2
                End With
            End If
        Next rw
    End With
End Sub

      

Answer 5

Only because I like puzzles:

Sub u5758()
Dim x As Long
Dim i As Long
Dim oArr() As Variant
Dim arr() As Long
Dim rng As Range
Dim ws As Worksheet
Application.ScreenUpdating = False
Set ws = ActiveSheet

x = 4
With ws
oArr = .Range(.Cells(1, 1), .Cells(.Rows.Count, 2).End(xlUp)).value
    For j = LBound(oArr, 1) To UBound(oArr, 1)
        ReDim arr(oArr(j, 1) To oArr(j, 2))
        For i = LBound(arr) To UBound(arr)
            arr(i) = i
        Next i
        .Cells(1, x).Resize(UBound(arr) - LBound(arr) + 1).value = Application.Transpose(arr)
        x = x + 1
    Next j
End With
Application.ScreenUpdating = True

End Sub