根据循环列中的值更改将范围粘贴到新工作表

Question

我对 excel VBA 相当陌生，并且在尝试开发宏时遇到了困难。我有一个访问数据库的输出，其中包含 A 到 S 列中的数据。输出的行数可变，但始终包含标题行。列 C 具有多行共有的值（即 C2:C7 可能是“香蕉”，而 C8:C9 可能是“篮子”，C10:C21 可能是“桶”），但是具有C列中的共同值是动态的。 C 列中的值始终是连续的。

我一直在尝试创建一个宏，该宏：识别 C 列中的值何时发生变化，将 C 列（和标题行）中具有相同值的行的 A 列粘贴到 S 列到使用列 C 值作为文件名，从原始工作簿中删除此范围，并循环获取 C 列中的值数。如果 C 列中有 3 个值，我的代码似乎有效；但是，如果不止于此，代码似乎会忽略在 C 列中查找值变化的标准，并创建新的工作簿，其范围包含 C 列中的多个值。

我认为这可能是由于循环的每次迭代都没有清除变量，但我在网上看到的所有内容都表明这不应该是一个问题。当我用 msgbox 替换新的工作簿代码而不是工作簿代码时，If 语句似乎有效。我相信这是 For 循环的问题，但我不知道如何解决这个问题。我用谷歌搜索并查看了无数的 SO 页面，但找不到我可以使用的答案。任何帮助将非常感激。

这是我的代码：

Sub number()

    Dim wbI As Workbook, wbO As Workbook
    Dim wsI As Worksheet, wsO As Worksheet
    Dim cell, rng As Range
    Set rng = Range("C2:C97")

    For Each cell In rng
        If cell.Value <> cell.Offset(1, 0).Value Then

        Set wbI = ActiveWorkbook
        Set wsI = wbI.Worksheets("Worklist")
        Set wbO = Workbooks.Add

            With wbO
                 Set wsO = wbO.Sheets("Sheet1")
                .SaveAs Filename:="C:\Users\svanwo0\Desktop\" & cell & ".xls", FileFormat:=56
                wsI.Range("A1:S1").Copy
                wsO.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                wsI.Rows("2:" & cell.Row).Copy
                wsO.Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                .Close SaveChanges:=True
            End With
        Set wbI = Nothing
        Set wsI = Nothing
        Set wbO = Nothing
        Set wsO = Nothing

        Rows("2:" & cell.Row).EntireRow.Delete (xlUp)

        End If
    Next cell


End Sub

提前致谢

vanw0001

Answer 1

这是在循环中前进并删除行会导致问题的情况之一。

您已经设置了它要迭代的范围。当您删除数据时，数据会向上移动，但您仍会转到下一个物理行，它不会每次都重置

由于您基本上是在删除日期的整个区域，所以我会等到最后再删除。我会创建一个变量来保存下一个数据块的起始行。

Sub number()

    Dim wbI As Workbook, wbO As Workbook
    Dim wsI As Worksheet, wsO As Worksheet
    Dim cell, rng As Range
    Dim stRw As Long
    Set rng = Range("C2:C97")
    stRw = 2
    For Each cell In rng
        If cell.Value <> cell.Offset(1, 0).Value Then

        Set wbI = ActiveWorkbook
        Set wsI = wbI.Worksheets("Worklist")
        Set wbO = Workbooks.Add

            With wbO
                 Set wsO = wbO.Sheets("Sheet1")
                .SaveAs Filename:="C:\Users\svanwo0\Desktop\" & cell & ".xls", FileFormat:=56
                wsI.Range("A1:S1").Copy
                wsO.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                wsI.Rows(stRw & ":" & cell.Row).Copy
                wsO.Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                .Close SaveChanges:=True
                stRw = cell.Row + 1
            End With
        Set wbI = Nothing
        Set wsI = Nothing
        Set wbO = Nothing
        Set wsO = Nothing



        End If
    Next cell
    Rows("2:97").EntireRow.Delete (xlUp)

End Sub