Question

我遇到了特定Excel任务的问题。虽然我在网上彻底搜索了我可以使用的提示和部分代码，但我无法接近有效的解决方案。

这是我的问题：

我有大约30个工作表，每个工作表有两列。行数从WS到WS不等，但每张表上的两列长度相等每个工作表的第一列包含最小值，第二列包含各自的最大值例如。

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

现在我需要一个包含这些间隔中所有值的单个列，包括Max和Min值。

C列中的优选溶液：
1000,1001,1002,1003,1004,1005,1006,1007,1008,1009,1010,2020,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

您可以随意使用的解决方案有点像这样：

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)以获取一个单元格中的所有数字或在子文档中使用它来自动执行此操作。< / p>

如果您有任何疑问，请询问：）

修改：

如果你想完全采用单列方式，你可以使用它（应该很快）：

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

如果您有任何疑问，请询问;）

Answer 3

已编辑：在“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

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

3 个答案: