Copying a range from all files within a folder and pasting into master workbook

问题

I'm fairly new to VBA so I apologize ahead of time. I've been getting involved with some complex operations and I would greatly appreciate some help or input.

With this macro, I am trying to:

1. Copy a specific range (2 column widths) from a specific sheet that is within all files in a given folder.
2. Paste the range values (and formatting if possible) in a column on the already open master workbook starting at B7 and moving over 2 columns for every new document so that the pasted data does not overlap.
3. Close files after copy/paste complete

As of right now I receive a

Run-time Error 9: Subscript out of range

for

Workbooks("RF_Summary_Template").Worksheets("Summary").Select

I know this is the least of my problems, though.

Below is my code:

Sub compile()

    Dim SummaryFile As String, SummarySheet As String, summaryColumn As Long
    Dim GetDir As String, Path As String
    Dim dataFile As String, dataSheet As String, LastDataRow As Long
    Dim i As Integer, FirstDataRow As Long


    '********************************

    RF_Summary_Template = ActiveWorkbook.Name  'summarybook
    Summary = ActiveSheet.Name     'summarysheet

    summaryColumn = Workbooks(RF_Summary_Template).Sheets(Summary).Cells(Columns.Count, 1).End(xlToLeft).Column + 1
    CreateObject("WScript.Shell").Popup "First, browse to the correct directory, select ANY file in the directory, and click Open.", 2, "Select Install Base File"

    GetDir = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*")

    If GetDir <> "False" Then
        Path = CurDir & "\"
    Else
        MsgBox "Directory not selected"
        Exit Sub
    End If

    Application.ScreenUpdating = False
    dataFile = Dir(Path & "*.xls")

    While dataFile <> ""
        Workbooks.Open (dataFile)
        Worksheets("Dashboard").Activate
        ActiveSheet.Range("AY17:AZ35").Copy

        Workbooks("RF_Summary_Template").Worksheets("Summary").Select
        Range("B8").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

        Workbooks(dataFile).Close
        summaryColumn = summaryColumn + 2

        dataFile = Dir()
    Wend

    Workbooks(RF_Summary_Template).Save
    Application.ScreenUpdating = True

End Sub

Thanks a million

回答1:

I hope this helps. Run the procedure "CopyDataBetweenWorkBooks"

Sub CopyDataBetweenWorkbooks()

    Dim wbSource As Workbook
    Dim shTarget As Worksheet
    Dim shSource As Worksheet
    Dim strFilePath As String
    Dim strPath As String

    ' Initialize some variables and
    ' get the folder path that has the files
    Set shTarget = ThisWorkbook.Sheets("Summary")
    strPath = GetPath

    ' Make sure a folder was picked.
    If Not strPath = vbNullString Then

        ' Get all the files from the folder
        strfile = Dir$(strPath & "*.xls", vbNormal)

        Do While Not strfile = vbNullString

            ' Open the file and get the source sheet
            Set wbSource = Workbooks.Open(strPath & strfile)
            Set shSource = wbSource.Sheets("Dashboard")


            'Copy the data
            Call CopyData(shSource, shTarget)

            'Close the workbook and move to the next file.
            wbSource.Close False
            strfile = Dir$()
        Loop
    End If

End Sub

' Procedure to copy the data.
Sub CopyData(ByRef shSource As Worksheet, shTarget As Worksheet)

    Const strRANGE_ADDRESS As String = "AY17:AZ35"

    Dim lCol As Long

    'Determine the last column.
    lCol = shTarget.Cells(8, shTarget.Columns.Count).End(xlToLeft).Column + 1

    'Copy the data.
    shSource.Range(strRANGE_ADDRESS).Copy
    shTarget.Cells(8, lCol).PasteSpecial xlPasteValuesAndNumberFormats

    ' Reset the clipboard.
    Application.CutCopyMode = xlCopy

End Sub


' Fucntion to get the folder path
Function GetPath() As String

    With Application.FileDialog(msoFileDialogFolderPicker)
        .ButtonName = "Select a folder"
        .Title = "Folder Picker"
        .AllowMultiSelect = False

        'Get the folder if the user does not hot cancel
        If .Show Then GetPath = .SelectedItems(1) & "\"

    End With

End Function

I hope this helps :)

回答2:

Sub fdsdf()

'template is in the f_path
'files are under fpath\Raw Data\Ban


f_path = tree

Set wbTemplate = Workbooks.Open(Filename:=f_path & "\DEMAND_Template.xlsx")
MyFolder = f_path & "\Raw Data\Ban"
MyFile = Dir(MyFolder & "\*.xlsx")
Do While MyFile <> ""
Set wbIB = Workbooks.Open(Filename:=MyFolder & "\" & MyFile)
wbIB.Activate

Sheets("Sheet1").Select

r_cnt = ActiveSheet.UsedRange.Rows.Count
ran1 = "12:" & r_cnt
Rows(ran1).Select
Selection.Copy
wbTemplate.Select

Sheets("Sheet1").Select
r_cnt1 = ActiveSheet.UsedRange.Rows.Count
ran2 = Sheets("Sheet1").Range("A1048576").End(xlUp).Row + 1
Range("A" & ran2).Select
ActiveSheet.Paste
Application.CutCopyMode = False
wbIB.Close False

MyFile = Dir
Loop

wbTemplate.Save

End Sub

回答3:

Sub final_consolidate()

f_path = "tree"

strFileToOpenIB = Application.GetOpenFilename(Title:="Please select the Consolidated file for Bangladesh", FileFilter:="Excel Files *.xlsx* (*.xlsx*),")
Set wbIB = Workbooks.Open(strFileToOpenIB)
wbIB.Activate
Sheets("Sheet1").Select
Sheets("Sheet1").Copy
wbIB.Activate
Sheets("Sheet2").Select
Sheets("Sheet2").Copy After:=Workbooks("Book1").Sheets(1)
wbIB.Activate
ActiveWorkbook.Close
Windows("Book1").Activate

strFileToOpenIB = Application.GetOpenFilename(Title:="Please select the Consolidated file for SriLanka", FileFilter:="Excel Files *.xlsx* (*.xlsx*),")
Set wbIB = Workbooks.Open(strFileToOpenIB)
wbIB.Activate
Sheets("Sheet1").Select
Sheets("Sheet1").Copy After:=Workbooks("Book1").Sheets(2)
wbIB.Activate
Sheets("Sheet2").Select
Sheets("Sheet2").Copy After:=Workbooks("Book1").Sheets(3)
wbIB.Activate
ActiveWorkbook.Close
Windows("Book1").Activate

ActiveWorkbook.SaveAs Filename:=f_path, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False


End Sub

来源：https://stackoverflow.com/questions/33405244/copying-a-range-from-all-files-within-a-folder-and-pasting-into-master-workbook