vba 用于合并数据的 Excel 宏

Excel macro to consolidate data

提问by user1568701

I have many excel files in a folder.

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

I wanted a macro to iterate through each file and copy sheet named final costand make a sheet with name of source file in destination file.

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

Like there are three files A, B, C each having a sheet named "final cost

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

The new file will have three sheets named

新文件将包含三张名为

• A,
• B,
• C

• 一种，
• 乙，
• C

The edited code looks like

编辑后的代码看起来像

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

The things now to do are:

现在要做的事情是：

1. preserve formatting and cell width
2. I can't get Paste Special to work
3. Delete worksheet with same name if exists

1. 保留格式和单元格宽度
2. 我无法让 Paste Special 工作
3. 如果存在，删除同名工作表

采纳答案by Siddharth Rout

You have got the most part figured out. Here is what I recommend.

你已经弄清楚了大部分。这是我推荐的。

Set a name for 1 main worksheet in the file from where the macro is run so that you can delete all sheets except that one sheet in 1 go. Let's say that the main sheet is "MainSheet"

在运行宏的文件中为 1 个主工作表设置一个名称，以便您可以一次删除除一张工作表之外的所有工作表。假设主表是“MainSheet”

For example

例如

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

Now you can add this code to the beginning of your code. I have modified your code. All I am doing in your code is after the sheet is created, simply delete the columns after Z.

现在您可以将此代码添加到代码的开头。我已经修改了你的代码。我在您的代码中所做的只是在创建工作表之后，只需删除 Z 之后的列。

See this (UNTESTED)

看到这个（未经测试）

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

Give it a try and if you get any errors, let me know which line and I will rectify it.

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