0

私はこのコードを持っています。一時シートにデータがなくなるまで繰り返したい。

1 週間分のデータで複数の Excel ファイルに書き込みたい 1 年間の情報を含む一時的なワークブックがあります。私がやろうとしているのは、一時的なワークブック「WorkingJan4newexperimental」からアクティブなワークブック (複数のワークブックに書き込んでいるため変更されます) にコピーすることですが、アクティブなワークブックのシートは常に「データ」になります。範囲「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 に答える