Question

我一直在研究一个宏，该宏将从6个不同的文件中获取数据，然后将这些数据粘贴到彼此之上的主文件中，以将它们全部合并到一个统一文件中。

我已经编写了这段代码，但是现在想添加到其中。我试图在粘贴所有数据的位置的左侧添加一列，以指定数据来自哪个文件，以便我们可以从主文件运行数据透视表。

例如，如果文件A有1000行数据，那么我希望列A的每个与文件A中数据相关联的行的值都为“ A”。如果文件B有2000行数据，那么对于所有这些行所有2000行都显示“ b”，而前1000行则显示“ a” .....

我在输入值方面的挑战还在于，这是一个动态范围，因此每次都不会是标准的行数。

下面是到目前为止我编写的代码，用于从单独的文件中提取所需的信息并将其复制并粘贴到主服务器上。

Sub MasterFile_Consolidate()

Dim LastRow As Long



MsgBox "This will take a few moments"

'Open MF
Workbooks.Open Filename:="C:\Users\zk4h90v\Desktop\MasterFile.xlsm", UpdateLinks:=False
    Worksheets("2019").Range("B4:BO65536").Clear

'Admin
Workbooks.Open Filename:="C:\Users\zk4h90v\Desktop\Radley Files\Admin.xlsm", UpdateLinks:=False, ReadOnly:=True, Password:="VWMTA2019!"
    Worksheets("Resource Plan").Activate
    On Error Resume Next
     Worksheets("Resource Plan").ShowAllData
    On Error GoTo 0
    Columns.EntireColumn.Hidden = False
    Rows.EntireRow.Hidden = False


LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

Workbooks("Admin.xlsm").Worksheets("Resource Plan").Range("A4:BO" & LastRow).Copy

Workbooks("MasterFile").Activate
Workbooks("MasterFile").Worksheets("2019").Cells(Cells.Rows.Count, 2).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = False

Workbooks("Admin.xlsm").Close SaveChanges:=False

'Blas
Workbooks.Open Filename:="C:\Users\zk4h90v\Desktop\Radley Files\Blas.xlsm", UpdateLinks:=False, ReadOnly:=True, Password:="vklf_blas4"
    Worksheets("Resource Plan").Activate
    On Error Resume Next
     Worksheets("Resource Plan").ShowAllData
    On Error GoTo 0
    Columns.EntireColumn.Hidden = False
    Rows.EntireRow.Hidden = False


LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

Workbooks("Blas.xlsm").Worksheets("Resource Plan").Range("A4:BO" & LastRow).Copy



Workbooks("MasterFile").Activate
Workbooks("MasterFile").Worksheets("2019").Cells(Cells.Rows.Count, 2).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = False

Workbooks("Blas.xlsm").Close SaveChanges:=False

'Epstein
Workbooks.Open Filename:="C:\Users\zk4h90v\Desktop\Radley Files\Epstein.xlsm", UpdateLinks:=False, ReadOnly:=True, Password:="ccce2019"
    Worksheets("Resource Plan").Activate
    On Error Resume Next
     Worksheets("Resource Plan").ShowAllData
    On Error GoTo 0
    Columns.EntireColumn.Hidden = False
    Rows.EntireRow.Hidden = False

LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

Workbooks("Epstein.xlsm").Worksheets("Resource Plan").Range("A4:BO" & LastRow).Copy


Workbooks("MasterFile").Activate
Workbooks("MasterFile").Worksheets("2019").Cells(Cells.Rows.Count, 2).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = False

Workbooks("Epstein.xlsm").Close SaveChanges:=False

'Deir
Workbooks.Open Filename:="C:\Users\zk4h90v\Desktop\Radley Files\Deir.xlsb", UpdateLinks:=False, ReadOnly:=True, Password:="GFCC2019rft"
    Worksheets("Resource Plan").Activate
    On Error Resume Next
     Worksheets("Resource Plan").ShowAllData
    On Error GoTo 0
    Columns.EntireColumn.Hidden = False
    Rows.EntireRow.Hidden = False

LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

Workbooks("Deir.xlsb").Worksheets("Resource Plan").Range("A4:BO" & LastRow).Copy


Workbooks("MasterFile").Activate
Workbooks("MasterFile").Worksheets("2019").Cells(Cells.Rows.Count, 2).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = False

Workbooks("Deir.xlsb").Close SaveChanges:=False

'Palazzotto
Workbooks.Open Filename:="C:\Users\zk4h90v\Desktop\Radley Files\Maria.xlsb", UpdateLinks:=False, ReadOnly:=True, Password:="DATA2019rft"
    Worksheets("Resource Plan").Activate
    On Error Resume Next
     Worksheets("Resource Plan").ShowAllData
    On Error GoTo 0
    Columns.EntireColumn.Hidden = False
    Rows.EntireRow.Hidden = False

LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

Workbooks("Maria.xlsb").Worksheets("Resource Plan").Range("A4:BO" & LastRow).Copy


Workbooks("MasterFile").Activate
Workbooks("MasterFile").Worksheets("2019").Cells(Cells.Rows.Count, 2).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = False

Workbooks("Maria.xlsb").Close SaveChanges:=False

'Thummala
Workbooks.Open Filename:="C:\Users\zk4h90v\Desktop\Radley Files\Mahesh.xlsm", UpdateLinks:=False, ReadOnly:=True, Password:="eit19ccor"
    Worksheets("Resource Plan").Activate
    On Error Resume Next
     Worksheets("Resource Plan").ShowAllData
    On Error GoTo 0
    Columns.EntireColumn.Hidden = False
    Rows.EntireRow.Hidden = False

LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

Workbooks("Mahesh.xlsm").Worksheets("Resource Plan").Range("A4:BO" & LastRow).Copy


Workbooks("MasterFile").Activate
Workbooks("MasterFile").Worksheets("2019").Cells(Cells.Rows.Count, 2).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = False

Workbooks("Mahesh.xlsm").Close SaveChanges:=False

MsgBox "Done"
End Sub

如果我可以包括这一行代码以适用于每个工作簿，那将是巨大的帮助！再次感谢您，如果我可以指定其他任何内容，请告诉我，我将立即发表评论。

Answer 1

将公共部分提取到一个独立的函数中将使您的代码受益，该函数仅从每个文件中获取数据。

已编译但未经测试：

Sub MasterFile_Consolidate()
    Const ROOT As String = "C:\Users\zk4h90v\Desktop\"
    Dim lastRow As Long, arrData, wbMaster As Workbook
    Dim shtMaster As Worksheet, arrPW, arrFiles, i as long

    MsgBox "This will take a few moments"

    'Open MF
    Set wbMaster = Workbooks.Open(Filename:=ROOT & "MasterFile.xlsm", _
                                  UpdateLinks:=False)

    Set shtMaster = wbMaster.Sheets("2019")
    shtMaster.Range("B4:BO65536").Clear

    arrFiles = Array("Admin.xlsm", "Blas.xlsm")'<< add the rest of your filenames here
    arrPW = Array("password1", "password2")'<< and the passwords here

    For i = lbound(arrFiles) to ubound(arrFiles) 

        arrData = FileData(ROOT & "Radley Files\" & arrFiles(i), arrPW(i)) '<< get the data from this file
        With shtMaster.Cells(Cells.Rows.Count, 2).End(xlUp).Offset(1, 0)
            .Resize(UBound(arrData, 1), UBound(arrData, 2)).Value = arrData '<< add the data
            .Offset(0, -1).Resize(UBound(arrData, 1), 1).Value = arrFiles(i) '<< add the filename
        End With

    Next i

    MsgBox "Done"
End Sub

'edited parameters...
Function FileData(fPath, PW)

    Dim wb As Workbook, sht As Worksheet, lastRow As Long, arrData

    Set wb = Workbooks.Open(Filename:=fPath, UpdateLinks:=False, _
                            Password:=PW)
    Set sht = wb.Worksheets("Resource Plan")
    On Error Resume Next
    sht.ShowAllData
    On Error GoTo 0
    sht.Columns.EntireColumn.Hidden = False
    sht.Rows.EntireRow.Hidden = False

    lastRow = sht.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    arrData = sht.Range(sht.Range("A4"), sht.Range("BO" & lastRow)) '<< get data as array
    wb.Close False

    FileData = arrData

End Function

在VBA中为粘贴的数据指定文件名...显示哪些文件数据来自

1 个答案: