複製範圍從文件夾和粘貼中的所有文件到主簿

Question

我是相當新的VBA讓我道歉的時間提前。我一直在參與一些複雜的操作，我會很感激一些幫助或輸入。

有了這個宏，我試圖：從處於一個給定的文件夾中的所有文件內的特定片

1. 複製一個特定的範圍（2點寬）。
2. 粘貼範圍內的值（如果可能的話格式化）在一列上已經打開的主工作簿起始於B7和爲每一個新的文檔上移動兩列，以使粘貼的數據不重疊。
3. 複製/粘貼完整

由於後關閉文件，現在我收到

運行時錯誤9：下標越界

爲

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

但我知道這是我的問題中最少的。

下面是我的代碼：

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 

萬分感謝

Answer 1

我希望這有助於。運行程序「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 

我希望這有助於:)