Excel文件合并自动化

Question

前提如下： 将不断从不同的机器生成单独的 excel 文件（db1_01.xslx、db1_02.xslx、db1_03.xslx 等），其中包含不同数量的行，其中包含信息（列号不会改变，将保持不变） ）。要求是将所有行放入一个 Excel 主文件中，并按计划自动合并。

所以我的第一个行动计划是将所有文件自动放置到一个文件夹中，这可以使用简单的移动/第 3 方文件夹同步应用程序等来完成。这部分很简单。

现在，我想知道在实践中自动合并行的最佳方法是什么？我正在考虑从同一位置读取包含文本“db *”的任何文件并将它们合并到 master，方法是获取 master 中最后一个未使用的行并在那里复制其他行。

我见过很多合并文件的 Excel/VBS 脚本，但我很难放置一个脚本来读取主文件中最后未使用的行并从文件中添加其他行，任何提示那？更常见的命令是什么？

我该如何自动化呢？我可以在任务计划程序上安排 .vbs 脚本吗？你们有没有人处理过这种情况？或许有什么软件可以推荐？

Answer 1

    strPathSrc = "C:\Test" ' Source files folder
strMaskSrc = "*.xlsx" ' Source files filter mask
iSheetSrc = 1 ' Sourse sheet index or name
strPathDst = "C:\Test\Results\Results.xlsx" ' Destination file
iSheetDst = 1 ' Destination sheet index or name

set objFSO = CreateObject("Scripting.FileSystemObject")
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Set objWorkBookDst = objExcel.Workbooks.Open(strPathDst)
Set objSheetDst = objWorkBookDst.Sheets(iSheetDst)
Set objShellApp = CreateObject("Shell.Application")
Set objFolder = objShellApp.NameSpace(strPathSrc)
Set objItems = objFolder.Items()
objItems.Filter 64 + 128, strMaskSrc
objExcel.DisplayAlerts = False
For Each objItem In objItems
    msgbox objItem.Path
    Set objWorkBookSrc = objExcel.Workbooks.Open(objItem.Path)
    Set objSheetSrc = objWorkBookSrc.Sheets(iSheetSrc)
    GetUsedRange(objSheetSrc).Copy
    Set objUsedRangeDst = GetUsedRange(objSheetDst)
    iRowsCount = objUsedRangeDst.Rows.Count
    objWorkBookDst.Activate
    objSheetDst.Cells(iRowsCount + 1, 1).Select
    objSheetDst.Paste
    objWorkBookDst.Application.CutCopyMode = False
    objWorkBookSrc.Close
    objFSO.DeleteFile(objItem.Path)
Next


Function GetUsedRange(objSheet)
    With objSheet
        Set GetUsedRange = .Range(.Cells(1, 1), .Cells(.UsedRange.Row + .UsedRange.Rows.Count - 1, .UsedRange.Column + .UsedRange.Columns.Count - 1))
    End With
End Function

VBS to compile information from multiple excel files into one

此脚本从一个位置读取所有 .xlsx 文件，因此无论您有多少文件，它都会解析 Results.xlsx 中的每一个和所有字段。

您可以使用任务计划将其设置为在所需的时间或频率运行。只需将脚本复制到某处，然后添加任务计划即可。

Results.xlsx 必须在运行之前创建。

Answer 2

我以前用那个来回答你的问题。

它将文件名复制到您要查找的文件所在的目录中。

您将文件放在一张 (FILES) 中，您可以选择要合并的文件。 合并后的文件将位于 (DB) 数据表中。

我的工作簿名为 CopyDb，但您可以自定义它。

   Sub CopyDb()

    Dim xRg, xCell As Range
    Dim xVal As String
    Dim MyPath, MyFileName, Aux As String
    Dim x
    Dim LastRow, LastCol As Long

    Set wsDb = ThisWorkbook.Worksheets("DB")
    Set wsFiles = ThisWorkbook.Worksheets("FILES")

    x = Shell("cmd /k type nul > list.txt", vbHide)
    x = Shell("cmd /k dir /A:-D /b > list.txt", vbHide)

    MyPath = ActiveWorkbook.Path
    MyFileName = "list.txt"
    Workbooks.OpenText Filename:=MyPath & "/list.txt" _
    , Origin:=xlWindows, StartRow:=1, DataType:=xlFixedWidth, FieldInfo:= _
    Array(0, 2), TrailingMinusNumbers:=True

    Windows("list.txt").Activate
    ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(ActiveSheet.UsedRange.Rows.Count, 1)).Copy
    Windows("list.txt").Close

    wsFiles.Activate
    wsFiles.Cells(1, 1).Activate
    wsFiles.Paste
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    wsFiles.Application.CutCopyMode = False
    Selection.NumberFormat = "@"

    x = Shell("cmd /k del list.txt /q", vbHide)

    Set xRg = Application.InputBox("Please select the file names:", , _
                       ActiveWindow.RangeSelection.Address, , , , , 8)
    If xRg Is Nothing Then Exit Sub

    For Each xCell In xRg
        xVal = xCell.Value
        If TypeName(xVal) = "String" And xVal <> "" Then
            Workbooks.Open (MyPath & "\" & xVal)
            Windows(xVal).Activate
            With ActiveWorkbook.ActiveSheet
                Range(.Cells(1, 1), .Cells(.UsedRange.Row + .UsedRange.Rows.Count - 1, _
                                 .UsedRange.Column + .UsedRange.Columns.Count - 1)).Copy
            End With
            ActiveWorkbook.Close
            Windows("CopyDb.xlsm").Activate
            LastRow = wsDb.UsedRange.SpecialCells(xlCellTypeLastCell).Row
            wsDb.Activate
            wsDb.Cells(LastRow + 1, 1).Select
            wsDb.Paste
            wsDb.Application.CutCopyMode = False
        End If
    Next
End Sub

希望对你有帮助