0

我有这个代码。我想让它迭代，直到临时表上没有更多数据。

我有一个临时工作簿，其中包含一年的信息，我想在一周的数据中写入多个 Excel 文件。我正在尝试做的是从临时工作簿“WorkingJan4newexperemental”复制到活动工作簿（由于我正在写入多个工作簿，该工作簿会发生变化），但活动工作簿中的工作表将始终为“数据”。我将复制范围“B6:I677”。复制后，我希望从临时工作簿中删除范围“B6：I677”，以便我可以打开另一个工作簿并再次运行宏。目前我有。

Sub CutPasteSaveRepeat()
'
' CutPasteSaveRepeat Macro
'

'
    Windows("WorkingJan4newexperemental.xlsm").Activate
    Range("B6:I677").Select
    Range("I677").Activate
    Application.CutCopyMode = False
    Selection.Copy
    Windows("2013W29.xlsm").Activate
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    ActiveWorkbook.Save
    ActiveWorkbook.SaveAs Filename:= _
        "\\Webserver\umc\091_AU20100226\210_Comments\Electricity\Capital Hall\Zip\2013W30.xlsm" _
        , FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    Windows("WorkingJan4newexperemental.xlsm").Activate
    Selection.Delete Shift:=xlUp
    Selection.Copy
    Windows("2013W30.xlsm").Activate
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    ActiveWorkbook.Save
    ActiveWorkbook.SaveAs Filename:= _
        "\\Webserver\umc\091_AU20100226\210_Comments\Electricity\Capital Hall\Zip\2013W31.xlsm" _
        , FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    Windows("WorkingJan4newexperemental.xlsm").Activate
    Selection.Delete Shift:=xlUp
    Selection.Copy
    Windows("2013W31.xlsm").Activate
    Application.CutCopyMode = False
      ActiveWorkbook.Save
    ActiveWorkbook.SaveAs Filename:= _
        "\\Webserver\umc\091_AU20100226\210_Comments\Electricity\Capital Hall\Zip\2013W32.xlsm" _
        , FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    Windows("WorkingJan4newexperemental.xlsm").Activate
    Selection.Copy
    Windows("2013W32.xlsm").Activate
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    ActiveWorkbook.Save
    Windows("WorkingJan4newexperemental.xlsm").Activate
    Selection.Delete Shift:=xlUp
    Windows("2013W33.xlsm").Activate
      ActiveWorkbook.Save
    ActiveWorkbook.SaveAs Filename:= _
        "\\Webserver\umc\091_AU20100226\210_Comments\Electricity\Capital Hall\Zip\2013W33.xlsm" _
        , FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    Windows("WorkingJan4newexperemental.xlsm").Activate
    Selection.Copy
    Windows("2013W34.xlsm").Activate
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    ActiveWorkbook.Save
End Sub

在此处输入图像描述 在此处输入图像描述

4

1 回答 1

1

听起来你想做的是：

  1. 从工作簿复制范围
  2. 将该范围粘贴到另一个工作簿
  3. 删除原始范围并将其下方的所有单元格向上移动
  4. 继续这样做，直到您复制了原始工作表中的所有数据

这是一个可以帮助您入门的子：

Sub copypasteiterate()

        Dim expBook As Workbook, thisBook As Workbook
        Dim counter As Integer
        Dim sheetend As Boolean

        Set thisBook = ActiveWorkbook

        counter = 1
        Do While sheetend = False

            If Range("A1").Value = "" Then sheetend = True

            'Open a new book and copy and paste the range into it

            Set expBook = Workbooks.Add
            thisBook.ActiveSheet.Range("A1:B2").Copy
            expBook.ActiveSheet.Paste

            'Save under some name which includes the counter

            expBook.SaveAs Filename:="C:\test\data" & counter & ".xlsx"
            counter = counter + 1

            'Delete the original range and shift up

            ThisWorkbook.Activate
            Range("A1:B2").Delete Shift:=xlUp
        Loop

 End Sub

我使用 A1:B2 作为我的范围，但你可以使用任何你需要使用的东西。文件名也是如此。我还假设您的数据中没有任何空白。如果有，您可能需要一种更复杂的方法来检查所有数据是否已被复制。

于 2013-01-04T21:13:20.410 回答