从文件夹中的所有文件复制范围，然后粘贴到主工作簿中 [英] Copying a range from all files within a folder and pasting into master workbook

问题描述

我刚接触VBA，因此提前致歉.我已经参与了一些复杂的操作，非常感谢您的帮助或投入.

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. 从给定文件夹中所有文件内的特定工作表中复制特定范围(2列宽).
2. 将范围值(如果可能的话，将其格式化)粘贴到已打开的主工作簿上的一列中，从B7开始，并为每个新文档移动两列，以使粘贴的数据不会重叠.
3. 复制/粘贴完成后关闭文件

截至目前，我收到

运行时错误9:下标超出范围

Run-time Error 9: Subscript out of range

为

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

不过，我知道这是我最少的问题.

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

下面是我的代码:

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

感谢一百万

推荐答案

我希望这会有所帮助.运行过程"CopyDataBetweenWorkBooks"

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 :)

这篇关于从文件夹中的所有文件复制范围，然后粘贴到主工作簿中的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！