查找范围内的值并打印到列

如何通过macros在下面的图像中生成Excel？ 简而言之，我想说：

• a1和b1之间的数字打印到d栏;
• a2和b2之间的数字打印到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

作为替代，这里是一个公式解决scheme：

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

虽然我意识到公式解决scheme可能是不可行的基于这个声明：

列A和B有数千个值。

编辑 ：纯数组VBA解决scheme：

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

你可以使用这个：

  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

这是另一个快速的只是为了好玩：

 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