希望将3个xls文件合并为一个。并将合并文件的值粘贴到主文件中

时间:2019-03-08 21:23:21

标签: excel vba

我在名为AM,MD,PM的3个XLS文件中有数据。我想使用VBA将所有3个XLS文件合并为1个XLS文件。

这3个XLS文件中的数据我也只希望从特定的行和列中获得。例如说从单元格A41到A53,B41到B53直到所有3个文件的U41到U53。结果,我希望只用剩下的行和列来合并生成xls文件。

生成此合并文件后,我想将这些值导入到主模板XLS文件中。因此,当我单击主Excel模板文件上的按钮时,它将合并3个XLS文件,生成一个文件,并应在主模板XLS文件中反映其值。[在此处输入图片描述] [1]

[在此处输入图片描述] [2]

在此处输入图片描述

Sub loopthroughDirectory()

Dim Myfile As String

Dim erow

Myfile = Dir("L:\Dept\TRANSPORTATION-ENGINEERING\TRAFFIC\_G ITS Projects\MS2\test\")


Do While Len(Myfile) > 0

If Myfile = "zmaster.xlsm" Then

Exit Sub
End If


Workbooks.Open (Myfile)
Range("A41:T53").Copy
ActiveWorkbook.Close


erow = car.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

ActiveSheet.Paste Destination:=Worksheets("Car").Range(Cells(erow, 1), 

Cells(erow, 20))


Myfile = Dir

Loop

End Sub

但这不起作用。它能够打开文件,但值未粘贴到我尝试生成的统一文件中。 建议将不胜感激。

1 个答案:

答案 0 :(得分:0)

我更喜欢通过“文件”对话框选择文件以获得一致性和可靠的结果,但要花几秒钟的时间多次选择文件。适用于您情况的代码可能是这样的:

Option Explicit

Sub Consolidation()

Dim CurrentBook As Workbook
Dim WS As Worksheet
Dim wsn As Worksheet
Set WS = ThisWorkbook.Sheets("car")
Dim IndvFiles As FileDialog
Dim FileIdx As Long
Dim i As Integer, x As Integer

Set IndvFiles = Application.FileDialog(msoFileDialogOpen)'Select your AM,Md, Pm files here
With IndvFiles
    .AllowMultiSelect = True
    .Title = "Multi-select target data files:"
    .ButtonName = ""
    .Filters.Clear
    .Filters.Add ".xls files", "*.xls"
    .Show
End With

Application.DisplayAlerts = False
Application.ScreenUpdating = False

For FileIdx = 1 To IndvFiles.SelectedItems.Count
    Set CurrentBook = Workbooks.Open(IndvFiles.SelectedItems(FileIdx))
   Set wsn = CurrentBook.Sheets(1)
        Dim LRow1 As Long
        LRow1 = WS.Range("A" & WS.Rows.Count).End(xlUp).Row
        Dim LRow2 As Long
        LRow2 = CurrentBook.ActiveSheet.Range("A" & CurrentBook.ActiveSheet.Rows.Count).End(xlUp).Row

        Dim ImportRange As Range
        Set ImportRange = CurrentBook.ActiveSheet.Range("A41:T53")' As per yr code adjust if required
        ImportRange.Copy
        WS.Range("A" & LRow1 + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    'Next
    CurrentBook.Close False
Next FileIdx

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub