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

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循环的问题，但我不确定如何解决。 我已经用Google搜索并查看了无数的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