查找指定间隔[Min;Max]中的所有数字，并将它们写在一列中

Question

我对一个特定的excel任务有问题。尽管我在网上彻底搜索了可以使用的技巧和代码部分，但我还是没能找到一个有效的解决方案。

这是我的问题：

我有大约30个工作表，每个工作表有两列。行数因WS而异，但每张工作表上的两列长度相等
每张图纸的第一列包含最小值，第二列包含相应的最大值
例如

  |   A  |  B
1 | 1000 | 1010  
2 | 2020 | 2025

现在，我需要一个单独的列，其中包含这些间隔中的所有值，包括最大值和最小值。

C列中的首选解决方案：
10001001、1002、1003、1004、1005、1006、1007、1008、1009、10102020、2021、2022、2023、2024、2025

我想突出显示这两列，然后激活一个宏来生成列表。然后，我将手动为每个WS重复此过程。有些纸张只有4到20行，但有些纸张有7000多行
如果有帮助的话：数字是邮政编码；-）

如果有任何帮助，我将不胜感激。

提前感谢！

Answer 1

试试这个：

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

Answer 2

编辑：在列"C"中有一个大字符串（在每个代码中添加两行）

编辑2：添加"zip3"解决方案，使所有值仅列在"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

Answer 3

一个可以随心所欲使用的解决方案应该是这样的：

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

如果您有任何问题，只需提问；）