查找指定时间间隔内的所有数字并将它们写入一列
我有一个特定的Excel任务的问题。 尽pipe我在网上彻底search了可以使用的代码的提示和部分代码，但我无法靠近function正常的解决scheme。
这是我的问题：
我有大约30个工作表，每个两列。 行数从WS到WS不等，但每个表中的两列同样长。
每张表的第一列包含最小值，第二列包含最大值。
例如
| A | B 1 | 1000 | 1010 2 | 2020 | 2025 现在我需要一个包含最大值和最小值的单个列。
列C中的首选解决scheme：
1000,1001,1002,1003,1004,1005,1006,1007,1008,1009,1010,2020,2021,2022,2023,2024,2025
我想突出显示两列，然后激活一个macros来生成列表。 然后我会手动为每个WS重复这个过程。 一些纸张只有4到20行，但有些则有7000多行。
如果它有帮助：数字是邮政编码;-)
我会很感激任何帮助。
提前致谢！
尝试这个：
Sub Test() Dim LastRow As Long, ColIndex As Long Dim i As Long, j As Long Dim min As Long, max As Long Dim ws As Worksheet For Each ws In ActiveWorkbook.Worksheets LastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row ColIndex = 1 For i = 1 To LastRow min = ws.Cells(i, 1).Value max = ws.Cells(i, 2).Value For j = min To max ws.Cells(ColIndex, 3).Value = j ColIndex = ColIndex + 1 Next j Next i Next ws End Sub
编辑 ：在“C”列中有一个大的string（在每个代码中添加两行）
编辑2 ：添加“zip3”解决scheme，只有“C”列中列出所有值
你可以使用下面的方法
Option Explicit Sub zips3() 'list values in column "C" in sequence from all min to max in columns "A" and "B" Dim sht As Worksheet Dim cell As Range For Each sht In ThisWorkbook.Sheets For Each cell In sht.Range("A1:A" & sht.Cells(sht.Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeConstants, xlNumbers) With cell.End(xlToRight).Offset(, 2).Resize(, cell.Offset(, 1).Value - cell.Value + 1) .FormulaR1C1 = "=RC1+COLUMN()-4" sht.Range("C" & sht.Cells(sht.Rows.Count, "C").End(xlUp).Row).Offset(1).Resize(.Columns.Count) = Application.Transpose(.Value) .ClearContents End With Next cell If IsEmpty(sht.Range("C1")) Then sht.Range("C1").Delete (xlShiftUp) Next sht End Sub Sub zips() 'list values in column "C" from corresponding min to max in columns "A" and "B" Dim sht As Worksheet Dim cell As Range Dim j As Long For Each sht In ThisWorkbook.Sheets For Each cell In sht.Range("A1:A" & sht.Cells(sht.Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeConstants, xlNumbers) For j = cell.Value To cell.Offset(, 1).Value cell.End(xlToRight).Offset(, 1) = j Next j 'lines added to have one bg string in column "C" cell.Offset(, 2).Value2 = "'" & Join(Application.Transpose(Application.Transpose(Range(cell.Offset(, 2), cell.Offset(, 2).End(xlToRight)))), ",") Range(cell.Offset(, 3), cell.Offset(, 3).End(xlToRight)).ClearContents Next cell Next sht End Sub Sub zips2() Dim sht As Worksheet Dim cell As Range For Each sht In ThisWorkbook.Sheets For Each cell In sht.Range("A1:A" & sht.Cells(sht.Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeConstants, xlNumbers) cell.End(xlToRight).Offset(, 1).Resize(, cell.Offset(, 1).Value - cell.Value + 1).FormulaR1C1 = "=RC1+COLUMN()-3" 'lines added to have one bg string in column "C" cell.Offset(, 2).Value2 = "'" & Join(Application.Transpose(Application.Transpose(Range(cell.Offset(, 2), cell.Offset(, 2).End(xlToRight)))), ",") Range(cell.Offset(, 3), cell.Offset(, 3).End(xlToRight)).ClearContents Next cell Next sht End Sub
你可以使用一个解决scheme，就像这样：
Public Function getZIPs(rng As Range) As String Dim myVal As Variant, str As String, i As Long, j As Long myVal = Intersect(rng, rng.Parent.UsedRange).Value For i = 1 To UBound(myVal) If IsNumeric(myVal(i, 1)) And IsNumeric(myVal(i, 2)) And Len(myVal(i, 1)) > 0 And Len(myVal(i, 2)) > 0 Then If myVal(i, 1) <= myVal(i, 2) Then For j = myVal(i, 1) To myVal(i, 2) str = str & ", " & j Next End If End If Next getZIPs = Mid(str, 3) End Function
把它放到一个模块中，然后去C1： =getZIPs(A1:B1)和自动填充或直接=getZIPs(A:B)来获得一个单元格中的所有数字，或者在一个单元格中使用它来自动完成。
如果你有问题，就问吧 ：）
编辑 ：
如果你想完全按照一列的方式，你可以使用这个（应该是快）：
Sub getMyList() Dim sCell As Range, gCell As Range Set gCell = ActiveSheet.[A1:B1] Set sCell = ActiveSheet.[C1] Dim sList As Variant While IsNumeric(gCell(1)) And IsNumeric(gCell(2)) And Len(gCell(1)) > 0 And Len(gCell(2)) > 0 If gCell(1) = gCell(2) Then sCell.Value = gCell(1) Set sCell = sCell.Offset(1) Else sList = Evaluate("ROW(" & gCell(1) & ":" & gCell(2) & ")") sCell.Resize(UBound(sList)).Value = sList Set sCell = sCell.Offset(UBound(sList)) End If Set gCell = gCell.Offset(1) Wend End Sub
如果你有问题，就问吧 ;）