2

フォルダ内に多くのExcelファイルがあります。

マクロで各ファイルを反復処理し、final costという名前のシートをコピーして、宛先ファイルにソースファイルの名前のシートを作成する必要がありました。

3つのファイルA、B、Cがあり、それぞれに「最終コスト」という名前のシートがあります。

新しいファイルには、3つのシートという名前が付けられます

  • A、
  • B、
  • C

編集されたコードは次のようになります

Sub RunCodeOnAllXLSFiles()
    Dim lCount As Long
    Dim wbResults As Workbook
    Dim wbCodeBook As Workbook

    'Application.ScreenUpdating = False
    'Application.DisplayAlerts = False
    'Application.EnableEvents = False

    'On Error Resume Next

    'Set wbCodeBook = ThisWorkbook

    Dim FilePath    As String, fName As String
    Dim aWB As Workbook, sWB As Workbook

    Set aWB = ActiveWorkbook
    FilePath = "D:\binny\" 'change to suit
    fName = Dir(FilePath & "*.xls")

    Do While fName <> ""
        If fName <> aWB.Name Then
            Set sWB = Workbooks.Open(FileName:=FilePath & fName, UpdateLinks:=0)
            sWB.Worksheets("Final Cost").Range("A1:Z6666").Copy
            sWB.Close False
            Sheets.Add.Name = fName
            Worksheets(fName).Range("D1").Select
            ActiveSheet.PasteSpecial Format:= _
            "Microsoft Word 8.0 Document Object"
        End If
        fName = Dir
    Loop
    Set sWB = Nothing: Set aWB = Nothing


               'Application.ScreenUpdating = True
    'Application.DisplayAlerts = True
    'Application.EnableEvents = True
End Sub

今やるべきことは次のとおりです。

  1. フォーマットとセル幅を保持する
  2. PasteSpecialを動作させることができません
  3. 同じ名前のワークシートが存在する場合は削除します
4

1 に答える 1

1

あなたは大部分を理解しました。これが私がお勧めするものです。

マクロを実行するファイルに1つのメインワークシートの名前を設定して、1枚に1枚のシートを除くすべてのシートを削除できるようにします。メインシートが「MainSheet」だとしましょう

例えば

Sub Sample()
    Dim ws As Worksheet

    For Each ws In ThisWorkbook.Sheets
        If ws.Name <> "MainSheet" Then
            Application.DisplayAlerts = False
            ws.Delete
            Application.DisplayAlerts = True
        End If
    Next ws
End Sub

これで、このコードをコードの先頭に追加できます。コードを変更しました。私があなたのコードで行っているのは、シートが作成された後、Zの後の列を削除することだけです。

これを参照してください（未テスト）

Sub test()
    Dim FilePath As String, fName As String
    Dim aWB As Workbook, sWB As Workbook
    Dim ws As Worksheet
    Dim ColName As String

    Set aWB = ThisWorkbook

    '~~> Delete sheets
    For Each ws In aWB.Sheets
        If ws.Name <> "MainSheet" Then
            Application.DisplayAlerts = False
            ws.Delete
            Application.DisplayAlerts = True
        End If
    Next ws

    FilePath = "D:\binny\" '<~~ Change to suit

    fName = Dir(FilePath & "*.xls")

    Do While fName <> ""
        If fName <> aWB.Name Then
            Set sWB = Workbooks.Open(Filename:=FilePath & fName, UpdateLinks:=0)
            sWB.Sheets("Final Cost").Move after:=aWB.Sheets(aWB.Sheets.Count)
            sWB.Close False
            '~~> The sheet is copied, simply delete the columns after Z
            With aWB.Sheets(aWB.Sheets.Count)
                .Name = fName
                .Cells.Copy
                .Cells.PasteSpecial xlPasteValues
                '~~> Get the last column Name
                ColName = Split(.Cells(, .Columns.Count).Address, "$")(1)
                .Columns("AA:" & ColName).Delete
            End With
        End If
        fName = Dir
    Loop
    Set sWB = Nothing: Set aWB = Nothing
End Sub

試してみてください。エラーが発生した場合は、どの行をお知らせください。修正します。

于 2012-08-03T06:48:01.637 に答える