Question

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

我有一份临时工作簿，其中包含一年的信息，我希望在一周的数据中写入多个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

enter image description here

Answer 1

这听起来像你要做的是：

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

这是一个应该让你入门的潜艇：

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作为我的范围，但你可以使用你需要使用的任何东西。同样适用于文件的名称。我还假设您的数据中没有任何空白。如果有，您可能需要更复杂的方法来检查是否已复制所有数据。

试图将数据从一个工作表写入另一个工作表

1 个答案: