Найти значения в диапазоне и распечатать в столбце

Question

Как я могу сгенерировать Excel, как на изображении ниже, через макрос? Коротко я хотел бы сделать:

• цифры между a1 и b1 print to d column;
• номера между столбцами a2 и b2 print to e;
• номера между символами a3 и b3 для f.

Столбцы A и B имеют тысячи значений.

Answer 1

только потому, что я люблю головоломки:

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 2

Вы могли бы использовать это:

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 3

Я тоже люблю головоломки.

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

В качестве альтернативы, вот формула решения:

=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) 

Хотя я понимаю, что формула решения не может быть осуществимо на основе этого заявления:

Столбцы A и B имеют тысячи значений.

EDIT: Чистый массив VBA решение:

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 5

Вот еще один быстрый один раз для удовольствия:

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