Find values in range and print to column - vba

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

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

Answer 3

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 4

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 5

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