vba - 用于合并数据的 Excel 宏

Question

我在一个文件夹中有很多excel文件。

我想要一个宏来遍历每个文件并复制名为最终成本的工作表，并在目标文件中制作一个带有源文件名称的工作表。

就像有三个文件 A、B、C，每个文件都有一张名为“最终成本”的表格

新文件将包含三个名为

• 一个，
• 乙，
• 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. 我无法让选择性粘贴工作
3. 如果存在，删除同名工作表

Answer 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

试一试，如果你有任何错误，让我知道哪一行，我会纠正它。