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

我是excel VBA的新手，在开发宏时遇到了困难。我有一个access数据库的输出，其中包含A到S列中的数据。该输出的行数可变，但始终包含一个标题行。列C具有多行通用的值（即C2:C7可能是“香蕉”，C8:C9可能是“篮子”，C10:C21可能是“桶”），但列C中具有通用值的行数是动态的。列C中的值始终是连续的

我一直在尝试创建一个宏：标识C列中的值何时更改，将C列（和标题行）中具有相同值的行的a列粘贴到S列，以C列值作为文件名保存到新工作簿，从原始工作簿中删除此范围，和循环表示C列中的值数。如果C列中有3个值，则我的代码似乎有效；但是，如果不止这些，代码似乎会忽略在C列中查找值更改的条件，并创建新工作簿，其范围在C列中包含多个值

我认为这可能是因为循环的每个迭代都没有清除变量，但我在web上看到的一切都表明这不应该是一个问题。当我将新工作簿代码替换为msgbox而不是工作簿代码时，If语句似乎可以工作。我相信这是For循环的一个问题，但我不确定如何解决这个问题。我在谷歌上搜索了无数页，但找不到我可以使用的答案。任何帮助都将不胜感激

这是我的密码：

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

子编号（）
将wbI设置为工作簿，将wbO设置为工作簿
将wsI设置为工作表，将wsO设置为工作表
暗淡单元格，rng As范围
设置rng=范围（“C2:C97”）
对于rng中的每个单元
如果单元格.Value单元格.Offset（1，0）.Value，则
设置wbI=ActiveWorkbook
设置wsI=wbI.Worksheets（“工作列表”）
设置wbO=工作簿。添加
与wbO
设置wsO=wbO.Sheets（“Sheet1”）
.SaveAs文件名：=“C:\Users\svanwo0\Desktop\”&cell&“.xls”，文件格式：=56
wsI.范围（“A1:S1”）.副本
wsO.Range（“A1”）.Paste特殊粘贴：=xlPasteValues，操作：=xlNone，SkipBlanks:=False，转置：=False
行（“2:&cell.Row”）。复制
wsO.Range（“A2”）.Paste特殊粘贴：=xlPasteValues，操作：=xlNone，SkipBlanks:=False，转置：=False
.Close SaveChanges:=True
以
设置wbI=Nothing
设置wsI=Nothing
设置wbO=Nothing
设置wsO=Nothing
行（“2:&cell.Row）.EntireRow.Delete（xlUp）
如果结束
下一个细胞
端接头

提前谢谢

---

vanw0001

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

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

因为你基本上是删除整个区域的日期，我会等到最后删除。我将创建一个变量来保存下一个数据块的起始行

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

子编号（）
将wbI设置为工作簿，将wbO设置为工作簿
将wsI设置为工作表，将wsO设置为工作表
暗淡单元格，rng As范围
暗stRw与长stRw相同
设置rng=范围（“C2:C97”）
stRw=2
对于rng中的每个单元
如果单元格.Value单元格.Offset（1，0）.Value，则
设置wbI=ActiveWorkbook
设置wsI=wbI.Worksheets（“工作列表”）
设置wbO=工作簿。添加
与wbO
设置wsO=wbO.Sheets（“Sheet1”）
.SaveAs文件名：=“C:\Users\svanwo0\Desktop\”&cell&“.xls”，文件格式：=56
wsI.范围（“A1:S1”）.副本
wsO.Range（“A1”）.Paste特殊粘贴：=xlPasteValues，操作：=xlNone，SkipBlanks:=False，转置：=False
行（stRw&“：”&cell.Row）。复制
wsO.Range（“A2”）.Paste特殊粘贴：=xlPasteValues，操作：=xlNone，SkipBlanks:=False，转置：=False
.Close SaveChanges:=True
stRw=单元格行+1
以
设置wbI=Nothing
设置wsI=Nothing
设置wbO=Nothing
设置wsO=Nothing
如果结束
下一个细胞
行（“2:97”）.EntireRow.Delete（xlUp）
端接头

这是循环前进和删除行会导致问题的实例之一。因为你基本上是删除整个区域的日期，我会等到最后删除。我将创建一个变量来保存下一个数据块的起始行。您已经设置了它要迭代的范围。当您删除数据时，数据会上移，但仍将转到下一个物理行，它不会每次都重置。