Copy a range of data from multiple chosen files

Question

I'm trying to copy data from multiple files over a range of cells.

I made something but I have to save files in a specific path or sometimes copy manually the range of cells in one workbook.

I want to choose the workbooks and save over an existing workbook, because the headers can have some references, and sometimes files have Protected VBA Projects.

My code copies one row from the first worksheet and also a range of cells from the second worksheet, from the files that are opened in a specified folder, then saves those cells to the file where the code is.

Sub LoopThroughDirectory()
    On Error Resume Next
    Dim MyFile As String
    Dim erow
    Dim erowc
    Dim Filepath As String
    Filepath = "C:\Users\noStress\Desktop\Workbook test\Destinatia mea\"
    MyFile = Dir(Filepath)

    Dim Matrice() As Variant
    Dim Dim1, Dim2 As Long

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Do While Len(MyFile) > 0
        If MyFile = "Transport_data.xlsm" Then
            Exit Sub
        End If

        Workbooks.Open (Filepath & MyFile)
        Worksheets(1).Activate
        Range("A2:M2").Copy
        Worksheets(2).Activate
        Dim1 = Range("A2", Range("A1").End(xlDown)).Cells.Count - 1
        Dim2 = Range("A1", Range("A1").End(xlToRight)).Cells.Count - 1

        ReDim Matrice(0 To Dim1, 0 To Dim2)
        For Dim1 = LBound(Matrice, 1) To UBound(Matrice, 1)
            For Dim2 = LBound(Matrice, 2) To UBound(Matrice, 2)

                Matrice(Dim1, Dim2) = Range("A2").Offset(Dim1, Dim2).Value

            Next Dim2
        Next Dim1
        ActiveWorkbook.Close

        Worksheets(2).Activate
        erowc = Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
        ThisWorkbook.Worksheets(2).Range(Cells(erowc, 1), Cells(Dim1 + erowc - 1, Dim2)).Value = Matrice

        Worksheets(1).Activate
        erow = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
        ActiveSheet.Paste Destination:=Worksheets(1).Range(Cells(erow, 1), Cells(erow, 14))

        MyFile = Dir
    Loop
End Sub

Not sure what the problem is? Are you getting errors? Is it not accomplishing what you want? — Kyle, Aug 20 '16 at 16:12
I am not getting erros, but I want to do the same thing with FileDialog, because i have to copy specific files to specific folder. — Andrei Vieru, Aug 20 '16 at 16:50

score 1 · Answer 1 · edited Sep 11 '16 at 16:03

I hope I got this right...

You want to:

Dynamically choose files from a specific folder
Copy cells from the chosen files in Sheet 1 and 2 to your current workbook
Save the current workbook? (I didn't fully understand what you meant here so I left this part out)

My take on it:

Create a userform (ufCopy) with a Listbox (lstFile, 2 columns) and a Command button (cmdCopy)
Create a command button on your sheet to start it
Check "Microsoft Scripting Runtime" in Extras -> References to avoid having to create objects
Copy this code into the userforms source code

Code:

    Private Sub UserForm_Initialize()

        Call GetFiles("C:\example\example") 'Enter your folder path here

    End Sub

    Private Sub GetFiles(strFile As String)

        '
        'Populates Listbox with all Excel files in the chosen folder and subfolders
        '

        Dim fso As Scripting.FileSystemObject
        Dim fsoFolder As Scripting.Folder
        Dim fsoSubfolder As Scripting.Folder
        Dim fsoFile As Scripting.File

        Set fso = New Scripting.FileSystemObject
        Set fsoFolder = fso.GetFolder(strFile)

        For Each fsoFile In fsoFolder.Files

            If Left(fso.GetExtensionName(fsoFile.Path), 2) = "xl" Then
                With Me.lstFiles
                    .AddItem
                    .List(.ListCount - 1, 0) = fsoFile.Name
                    .List(.ListCount - 1, 1) = fsoFile.Path
                End With
            End If

        Next fsoFile

        For Each fsoSubfolder In fsoFolder.SubFolders

            Call GetFiles(fsoSubfolder.Path)

        Next fsoSubfolder

    End Sub

    Private Sub cmdCopy_Click()

        Dim Msg As String
        Dim iCounter As Integer
        Dim wbCur As Workbook

        Application.ScreenUpdating = False   

        For iCounter = 0 To Me.lstFiles.ListCount - 1

             If Me.lstFiles.Selected(iCounter) Then

                Set wbCur = Workbooks.Open(Me.lstFiles.List(iCounter, 0) & Me.lstFiles.List(iCounter, 1))
                '
                'Copy from first sheet
                '
                wbCur.Worksheets(1).Range("A2:M2").Copy Destination:=ThisWorkbook.Worksheets(1).Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
                '
                'Copy from second sheet
                '
                With wbCur.Worksheets(2)
                    .Range("A1", .Range("A2").End(xlDown).End(xlToRight)).Copy Destination:=ThisWorkbook.Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                End With

                wbCur.Close savechanges:=False

              End If
        Next iCounter

        Application.ScreenUpdating = True
    End Sub

This does:

Show all Excel files of the chosen folder and subfolders in a Multiselect Listbox
Loops through all selected workbooks and copies the cells to this one

I didn't see the purpose of that array so I removed it. You can freely adjust the code for copying to your needs tho.

To start the userform, copy this into the Code for the sheet containing your command button:

Private Sub CommandButton1_Click()

    ufCopy.Show

End Sub

Edit: To dynamically choose your folder path, use this:

Private Sub UserForm_Initialize()

Dim strFolder
Dim fdFolder As FileDialog

' Open the file dialog
Set fdFolder = Application.FileDialog(msoFileDialogFolderPicker)
fdFolder.AllowMultiSelect = False
fdFolder.Show

strFolder = fdFolder.SelectedItems(1)

Call GetFiles(strFolder)

End Sub

If you want to get the files from different paths, just add the above code to a command button on your userform instead of intialize. That way you can click on it and add multiple directories.

this is so close to my needs. I deleted Workbooks.Open(Me.lstFiles.List(iCounter, 0) & from wbCur intializiation because it didn't open the file. I want to be able to specify somehow the path of the files, because i can have my needed files in multiple paths. — Andrei Vieru, Aug 21 '16 at 12:33
Use the initialize below my Edit instead. It will prompt you to chose your path in a file dialog. What do you mean by "Doesn't open my file"? Do you get an error? Is the file not shown in the listbox? I just tested it and it works for me. — Chrowno, Aug 21 '16 at 12:49
That part gave me the run time error 1004, it told me that "Transport_datapath" doesn't exist. The folder path selection above makes only one single choise of the folder, then stops and I don't necessary need that editbox, I will try to change it somehow by choosing directly the files needed with filedialog and I have to make it more portable, because i'm running this code on virtual machines and is not too eficient to activate on every machine Microsoft Scripting Runtime. Thx, I'm grateful cuz now I got the idea of doing this code. — Andrei Vieru, Aug 22 '16 at 06:49

score 1 · Accepted Answer · answered Aug 21 '16 at 23:08

Comments on your code

Application.DisplayAlerts = False means the user will not see any alerts. In my view this is dangerous. I use this statement so:

Application.DisplayAlerts = False
Delete worksheet
Application.DisplayAlerts = True

That is, I switch off alerts for a single statement. I will have already checked with the user, if appropriate, that it alright to delete the worksheet.

If MyFile = "Transport_data.xlsm" Then
  Exit Sub
End If

I assume Transport_data.xlsm is the workbook containing the macro. Typically, Dir returns files in the order created so any files created after Transport_data.xlsm will not be processed. You want something like:

If MyFile <> "Transport_data.xlsm" Then
  Process file
End If

It is worth noting that ThisWorkbook.Name gives the name of the workbook holding the macro that is running. So the following would still work if you change the name of the workbook:

If MyFile <> ThisWorkbook.Name Then
  Process file
End If

Worksheets(N) is the Nth worksheet along the Tab. If the user changes the sequence of the worksheets, the worksheet numbers change and you may not get the worksheet you expect.

Always identify a worksheet by name: Worksheets("xxxxx")

Worksheets(N)Activate is slow and should be avoided.

In the following, you activate Worksheets(2) then fully qualify which worksheet you want in the Following statement:

Worksheets(2).Activate
erowc = Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

You do not need the Activate

You use

`ThisWorkbook.Worksheets(2).Range(Cells(erowc, 1), Cells(Dim1 + erowc - 1, Dim2)).Value = Matrice`

to download to the destination range but load Matrice from the source range cell by cell. You can load Matrice in the same way.

Dim Matrice As Variant

Matrice = SourceRange.Value          ' This will size Matrice as required
DestinationRange.Value = Matrice

Your requirement

You want to extract data from multiple workbooks not all stored in the same folder. You assume (hope) the worksheet you require is the first worksheet. Your macro copies the entire worksheet but your text implies you want to be more selective. Since you want to automate the process, I assume this is a process that is repeated at intervals.

I am perhaps leaping to conclusions but this sounds like a requirement of one of my clients. They received multiple workbooks from their sources but they only needed selected information for their management summary. They were performing the consolidation manually which was time consuming and error prone. If your requirement is anything like theirs, you do not want the user to select files; you want the process fully automated. I no longer have the code I created for that client but I have created a simple version from memory.

I have created a workbook with a worksheet named “Instructions”. They had multiple such worksheets because they had several consolidations. However, one is enough to show the principle. The worksheet has multiple rows. Each row specifies the copying of a range from one workbook to another. The columns are:

Source         Folder
range          Workbook name
               Worksheet name
               Left column      \
               Top row          |  Source range
               Right column     |
               Bottom row       /

Destination    Folder
range          Workbook name
               Worksheet name
               Top left destination cell

This is an image of my test data:

Note: this data is designed to test the macro; it is not a particularly sensible set of instructions.

In the system I created for the client and the simple macro I have created for you, Folder is a fixed string. For example: “C:\Users\noStress\Desktop\Workbook test\Destinatia mea” or “C:\Users\ajdal\Desktop\Workbooks\CopyRanges”. The folder name must be specified on the first instruction row. It only need be specified on subsequent rows if it changes.

In the macro I have created for you, Workbook name is fixed. For example: “A.xlsx” or “B.xlsx”. In my client’s system, it is a template, for example: “Branch A *.xlsx”. The macro would pick the latest file from the folder that matched this template.

In both systems, Worksheet name is fixed.

Note: If a new folder is specified, a new workbook name and a new worksheet name is required. If a new workbook name is specified, a new worksheet name is required.

Values are always required in Left, Top, Rght and Bot. The sequence is chosen so it looks like a range. The advantage of having these as separate columns (rather than, for example, “A1:D8”) is that it is easy to allow for words such as “Last” so “A|1|Last|Last” would specify an entire worksheet and “A|Last|Last|Last” the entire last row. This functionality is not included in the macro below.

Rules for the destination folder, workbook and worksheet are as for source.

Only the top left cell is needed for the destination. I have included code to allow for “D” or “A” as the destination which mean down from the previous copy or across from the previous copy.

If a value within an instruction row is missing or wrong, the cell is coloured Rose and the row is ignored. The macro continues with the next row so as many of the instructions as possible can be tested in one go. For example:

The macro probably has too much validation and not enough testing. For the client, non-technical staff created the instruction worksheets. If they misspelt a workbook or worksheet name, the macro could not just stop on the workbook open or worksheet access so everything was validated. I have included that validation but have not tested for every possible user error. I always include Debug.Assert False at the top of every path through my macros. When during testing, a path is executed, I comment out the Debug.Assert False. Any that remain uncommented at the end of testing either indicate my testing was inadequate or that my design was faulty and the path cannot be reached. Here the indicate error conditions I have not tested.

Note: I have used SourceRange.Copy Destination:=TopLeftCell to copy data. This has the advantage that formatting is copied but has the disadvantage that formulae are also copied. If this is unacceptable, copying via a Variant array may be better.

If this functionality sounds interesting, have a play with the macro.

Option Explicit

  Const ClrError As Long = 13408767   ' Rose = RGB(255, 153, 204)
  Const ClrSrc As Long = 10092543     ' Light yellow = RGB(255, 255, 153)
  Const ClrDest As Long = 16777164    ' Light turquoise - RGB(204, 255, 255)

  Const ColInstSrcFld As Long = 1
  Const ColInstSrcWbk As Long = 2
  Const ColInstSrcWsht As Long = 3
  Const ColInstSrcColLeft As Long = 4
  Const ColInstSrcRowTop As Long = 5
  Const ColInstSrcColRight As Long = 6
  Const ColInstSrcRowBot As Long = 7
  Const ColInstDestFld As Long = 8
  Const ColInstDestWbk As Long = 9
  Const ColInstDestWsht As Long = 10
  Const ColInstDestRng As Long = 11
  Const ColsSrc As String = "A:G"     ' \ Used for colouring columns
  Const ColsDest As String = "H:K"    ' /
Sub CopyRanges()

  Dim ColDest As Long
  Dim ColSrcLeft As Long
  Dim ColSrcRight As Long
  Dim DestFldStr As String
  Dim DestWbkStr As String
  Dim DestWbkChanged As Boolean
  Dim DestWshtStr As String
  Dim DestRngStr As String
  Dim ErrorOnRow As Boolean
  Dim NumColsRngSrc As Long
  Dim NumRowsRngSrc As Long
  Dim RngDest As Range
  Dim RngSrc As Range
  Dim RowDest As Long
  Dim RowInstCrnt As Long
  Dim RowInstLast As Long
  Dim RowSrcBot As Long
  Dim RowSrcTop As Long
  Dim SrcFldStr As String
  Dim SrcWbkStr As String
  Dim SrcWshtStr As String
  Dim WbkDest As Workbook
  Dim WbkSrc As Workbook
  Dim WshtDest As Worksheet
  Dim WshtInst As Worksheet
  Dim WshtSrc As Worksheet

  ' Note the initial values for variables are:
  '   0  for Long
  '   "" for String
  '   Nothing for Object (for example: workbook, worksheet, range)

  Application.ScreenUpdating = False

  Set WshtInst = Worksheets("Instructions")

  With WshtInst
    ' Restore background colour of source and destination columns
    ' to clear and error recorded by last run.
    .Columns(ColsSrc).Interior.Color = ClrSrc
    .Columns(ColsDest).Interior.Color = ClrDest

    ' Find last row of instructions
    RowInstLast = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious).Row
  End With

  For RowInstCrnt = 3 To RowInstLast

    With WshtInst
      ErrorOnRow = False

      ' Validate source columns of instructions
      If .Cells(RowInstCrnt, ColInstSrcFld).Value <> "" Then
        ' New source folder; must be new workbook and worksheet
        'Debug.Assert False
        If .Cells(RowInstCrnt, ColInstSrcWbk).Value = "" Then
          Debug.Assert False
          .Cells(RowInstCrnt, ColInstSrcWbk).Interior.Color = ClrError  ' Record faulty value
          ErrorOnRow = True
        End If
        If .Cells(RowInstCrnt, ColInstSrcWsht).Value = "" Then
          Debug.Assert False
          .Cells(RowInstCrnt, ColInstSrcWsht).Interior.Color = ClrError  ' Record faulty value
          ErrorOnRow = True
        End If
      ElseIf .Cells(RowInstCrnt, ColInstSrcWbk).Value <> "" Then
        ' New source workbook; must be new worksheet
        'Debug.Assert False
        If .Cells(RowInstCrnt, ColInstSrcWsht).Value = "" Then
          'Debug.Assert False
          .Cells(RowInstCrnt, ColInstSrcWsht).Interior.Color = ClrError  ' Record faulty value
          ErrorOnRow = True
        End If
      End If

      ' Source range must always be specified in full

      ' Top row must be non-empty, numeric and a valid row number
      If .Cells(RowInstCrnt, ColInstSrcRowTop).Value = "" Then
        'Debug.Assert False
        .Cells(RowInstCrnt, ColInstSrcRowTop).Interior.Color = ClrError  ' Record faulty value
        ErrorOnRow = True
      ElseIf Not IsNumeric(.Cells(RowInstCrnt, ColInstSrcRowTop).Value) Then
        Debug.Assert False
        .Cells(RowInstCrnt, ColInstSrcRowTop).Interior.Color = ClrError  ' Record faulty value
        ErrorOnRow = True
      Else
        RowSrcTop = .Cells(RowInstCrnt, ColInstSrcRowTop).Value
        If RowSrcTop < 1 Or RowSrcTop > Rows.Count Then
          .Cells(RowInstCrnt, ColInstSrcRowTop).Interior.Color = ClrError  ' Record faulty value
          ErrorOnRow = True
        End If
      End If

      ' Left column must be non-empty and a valid column code
      If .Cells(RowInstCrnt, ColInstSrcColLeft).Value = "" Then
        Debug.Assert False
        .Cells(RowInstCrnt, ColInstSrcColLeft).Interior.Color = ClrError  ' Record faulty value
        ErrorOnRow = True
      Else
        ColSrcLeft = ColNum(.Cells(RowInstCrnt, ColInstSrcColLeft).Value)
        If ColSrcLeft = 0 Then
          Debug.Assert False
          .Cells(RowInstCrnt, ColInstSrcColLeft).Interior.Color = ClrError  ' Record faulty value
        End If
      End If

      ' Bottom row must be non-empty, numeric and a valid row number greater or equal to top row
      If .Cells(RowInstCrnt, ColInstSrcRowBot).Value = "" Then
        Debug.Assert False
        .Cells(RowInstCrnt, ColInstSrcRowBot).Interior.Color = ClrError  ' Record faulty value
        ErrorOnRow = True
      ElseIf Not IsNumeric(.Cells(RowInstCrnt, ColInstSrcRowBot).Value) Then
        Debug.Assert False
        .Cells(RowInstCrnt, ColInstSrcRowBot).Interior.Color = ClrError  ' Record faulty value
        ErrorOnRow = True
      Else
        RowSrcBot = .Cells(RowInstCrnt, ColInstSrcRowBot).Value
        If RowSrcBot < 1 Or RowSrcBot > Rows.Count Or RowSrcTop > RowSrcBot Then
          .Cells(RowInstCrnt, ColInstSrcRowTop).Interior.Color = ClrError  ' Record faulty value
          ErrorOnRow = True
        End If
      End If

      ' right column must be non-empty and a valid column code greater or equal to left column
      If .Cells(RowInstCrnt, ColInstSrcColRight).Value = "" Then
        Debug.Assert False
        .Cells(RowInstCrnt, ColInstSrcColRight).Interior.Color = ClrError  ' Record faulty value
        ErrorOnRow = True
      Else
        ColSrcRight = ColNum(.Cells(RowInstCrnt, ColInstSrcColRight).Value)
        If ColSrcRight = 0 Or ColSrcLeft > ColSrcRight Then
          Debug.Assert False
          .Cells(RowInstCrnt, ColInstSrcColRight).Interior.Color = ClrError  ' Record faulty value
        End If
      End If

      ' If no error in source columns, load new values from instruction row to variables.
      ' Check have value for every parameter. Check folder and workbook exist if specified
      ' Close old workbook if appropriate. Open new workbook if appropriate
      If Not ErrorOnRow Then
        'Debug.Assert False
        If .Cells(RowInstCrnt, ColInstSrcFld).Value <> "" Then
          ' New source folder
          'Debug.Assert False
          SrcFldStr = .Cells(RowInstCrnt, ColInstSrcFld).Value
          If Right$(SrcFldStr, 1) <> "\" Then
            'Debug.Assert False
            SrcFldStr = SrcFldStr & "\"
          End If
          If Not PathExists(SrcFldStr) Then
            Debug.Assert False
            .Cells(RowInstCrnt, ColInstSrcFld).Interior.Color = ClrError  ' Record faulty value
            SrcFldStr = ""
            ErrorOnRow = True
          End If
        ElseIf SrcFldStr = "" Then
          ' No source folder specified
          Debug.Assert False
          .Cells(RowInstCrnt, ColInstSrcFld).Interior.Color = ClrError  ' Record faulty value
          ErrorOnRow = True
        End If
      End If
      If Not ErrorOnRow Then
        'Debug.Assert False
        If .Cells(RowInstCrnt, ColInstSrcWbk).Value <> "" Then
          ' New source workbook; close old one if any
          'Debug.Assert False
          If Not WbkSrc Is Nothing Then
            'Debug.Assert False
            WbkSrc.Close SaveChanges:=False
            Set WbkSrc = Nothing
          End If
          SrcWbkStr = .Cells(RowInstCrnt, ColInstSrcWbk).Value
          If FileExists(SrcFldStr, SrcWbkStr) Then
            'Debug.Assert False
            Set WbkSrc = Workbooks.Open(FileName:=SrcFldStr & SrcWbkStr, _
                                        UpdateLinks:=True, ReadOnly:=True)
          Else
            'Debug.Assert False
            .Cells(RowInstCrnt, ColInstSrcWbk).Interior.Color = ClrError  ' Record faulty value
            ErrorOnRow = True
          End If
        End If
      End If
      If Not ErrorOnRow Then
        'Debug.Assert False
        If .Cells(RowInstCrnt, ColInstSrcWsht).Value <> "" Then
          'Debug.Assert False
          SrcWshtStr = .Cells(RowInstCrnt, ColInstSrcWsht).Value
          If WshtExists(WbkSrc, SrcWshtStr) Then
            'Debug.Assert False
            Set WshtSrc = WbkSrc.Worksheets(SrcWshtStr)
          Else
            'Debug.Assert False
            .Cells(RowInstCrnt, ColInstSrcWsht).Interior.Color = ClrError  ' Record faulty value
            ErrorOnRow = True
          End If
        End If
      End If
      If Not ErrorOnRow Then
        'Debug.Assert False
        Set RngSrc = WshtSrc.Range(WshtSrc.Cells(RowSrcTop, ColSrcLeft), _
                                   WshtSrc.Cells(RowSrcBot, ColSrcRight))
      End If

      ' Validate destination columns of instructions.
      If .Cells(RowInstCrnt, ColInstDestFld).Value <> "" Then
        ' New destination folder; must be new workbook, worksheet and range
        'Debug.Assert False
        If .Cells(RowInstCrnt, ColInstDestWbk).Value = "" Then
          Debug.Assert False
          .Cells(RowInstCrnt, ColInstDestWbk).Interior.Color = ClrError  ' Record faulty value
          ErrorOnRow = True
        End If
        If .Cells(RowInstCrnt, ColInstDestWsht).Value = "" Then
          Debug.Assert False
          .Cells(RowInstCrnt, ColInstDestWsht).Interior.Color = ClrError  ' Record faulty value
          ErrorOnRow = True
        End If
        If .Cells(RowInstCrnt, ColInstDestRng).Value = "" Then
          Debug.Assert False
          .Cells(RowInstCrnt, ColInstDestRng).Interior.Color = ClrError  ' Record faulty value
          ErrorOnRow = True
        End If
      ElseIf .Cells(RowInstCrnt, ColInstDestWbk).Value <> "" Then
        ' New destination workbook; must be new worksheet and range
        'Debug.Assert False
        If .Cells(RowInstCrnt, ColInstDestWsht).Value = "" Then
          Debug.Assert False
          .Cells(RowInstCrnt, ColInstDestWsht).Interior.Color = ClrError  ' Record faulty value
          ErrorOnRow = True
        End If
        If .Cells(RowInstCrnt, ColInstDestRng).Value = "" Then
          Debug.Assert False
          .Cells(RowInstCrnt, ColInstDestRng).Interior.Color = ClrError  ' Record faulty value
          ErrorOnRow = True
        End If
      End If
      If .Cells(RowInstCrnt, ColInstDestRng).Value = "" Then
        ' Destination range must always be specified
        Debug.Assert False
        .Cells(RowInstCrnt, ColInstDestRng).Interior.Color = ClrError  ' Record faulty value
        ErrorOnRow = True
      End If

      ' If no error in destination columns, load new values from instruction row to variables.
      ' Check have value for every parameter. Check folder and workbook exist if specified
      ' Close old workbook if appropriate. Open new workbook if appropriate
      If Not ErrorOnRow Then
        'Debug.Assert False
        If .Cells(RowInstCrnt, ColInstDestFld).Value <> "" Then
          ' New destination folder
          'Debug.Assert False
          DestFldStr = .Cells(RowInstCrnt, ColInstDestFld).Value
          If Right$(DestFldStr, 1) <> "\" Then
            DestFldStr = DestFldStr & "\"
          End If
          If Not PathExists(DestFldStr) Then
            Debug.Assert False
            .Cells(RowInstCrnt, ColInstDestFld).Interior.Color = ClrError  ' Record faulty value
            DestFldStr = ""
            ErrorOnRow = True
          End If
        ElseIf DestFldStr = "" Then
          ' No destination folder specified
          Debug.Assert False
          .Cells(RowInstCrnt, ColInstDestFld).Interior.Color = ClrError  ' Record faulty value
          ErrorOnRow = True
        End If
      End If
      If Not ErrorOnRow Then
        'Debug.Assert False
        If .Cells(RowInstCrnt, ColInstDestWbk).Value <> "" Then
          ' New destination workbook; close old one if any
          'Debug.Assert False
          If Not WbkDest Is Nothing Then
            'Debug.Assert False
            If DestWbkChanged Then
              'Debug.Assert False
              WbkDest.Close SaveChanges:=True
              DestWbkChanged = False
            Else
              Debug.Assert False
              WbkDest.Close SaveChanges:=False
            End If
            Set WbkDest = Nothing
          End If
          DestWbkStr = .Cells(RowInstCrnt, ColInstDestWbk).Value
          If FileExists(DestFldStr, DestWbkStr) Then
            'Debug.Assert False
            Set WbkDest = Workbooks.Open(FileName:=DestFldStr & DestWbkStr, _
                                         UpdateLinks:=True, ReadOnly:=False)
            DestWbkChanged = False
          Else
            'Debug.Assert False
            .Cells(RowInstCrnt, ColInstDestWbk).Interior.Color = ClrError  ' Record faulty value
            ErrorOnRow = True
          End If
        Else
          ' No new workbook. Check one remains open from previous instructions
          If WbkDest Is Nothing Then
            'Debug.Assert False
            .Cells(RowInstCrnt, ColInstDestWbk).Interior.Color = ClrError  ' Record faulty value
            ErrorOnRow = True
          End If
        End If
      End If
      If Not ErrorOnRow Then
        'Debug.Assert False
        If .Cells(RowInstCrnt, ColInstDestWsht).Value <> "" Then
          'Debug.Assert False
          DestWshtStr = .Cells(RowInstCrnt, ColInstDestWsht).Value
          If WshtExists(WbkDest, DestWshtStr) Then
            'Debug.Assert False
            Set WshtDest = WbkDest.Worksheets(DestWshtStr)
            ' Clear source range and destination cell information saved from
            ' previous instruction row and used in processing "destination cells"
            ' A(cross) and D(own).
            RowDest = 0
            ColDest = 0
            NumRowsRngSrc = 0
            NumColsRngSrc = 0
          Else
            Debug.Assert False
            .Cells(RowInstCrnt, ColInstDestWsht).Interior.Color = ClrError  ' Record faulty value
            ErrorOnRow = True
          End If
        End If
      End If
      If Not ErrorOnRow Then
        'Debug.Assert False
        Select Case UCase(.Cells(RowInstCrnt, ColInstDestRng).Value)
          Case "D"    ' Down from previous transfer
            ' Should have RowDest, ColDest, NumRowsRngSrc and NumColsRngSrc from
            ' last instruction row
            'Debug.Assert False
            If RowDest = 0 Or ColDest = 0 Or NumRowsRngSrc = 0 Or NumColsRngSrc = 0 Then
              ' No appropriate previous instruction row
              Debug.Assert False
              .Cells(RowInstCrnt, ColInstDestRng).Interior.Color = ClrError  ' Record faulty value
              ErrorOnRow = True
            Else
              'Debug.Assert False
              ' Calculate new row from information saved from last
              ' error-free instruction row.  Column unchanged.
              RowDest = RowDest + NumRowsRngSrc
            End If
          Case "A"    ' Across from previous transfer
            ' Should have RowDest, ColDest, NumRowsRngSrc and NumColsRngSrc from
            ' last instruction row
            'Debug.Assert False
            If RowDest = 0 Or ColDest = 0 Or NumRowsRngSrc = 0 Or NumColsRngSrc = 0 Then
              ' No appropriate previous instruction row
              Debug.Assert False
              .Cells(RowInstCrnt, ColInstDestRng).Interior.Color = ClrError  ' Record faulty value
              ErrorOnRow = True
            Else
              'Debug.Assert False
              ' Calculate new column from information saved from last
              ' error-free instruction row. Row unchanged
              ColDest = ColDest + NumColsRngSrc
            End If
          Case Else
            'Debug.Assert False
            DestRngStr = .Cells(RowInstCrnt, ColInstDestRng).Value
            Err.Clear
            On Error Resume Next
            Set RngDest = WshtDest.Range(DestRngStr)
            On Error GoTo 0
            If Err <> 0 Then
              Debug.Assert False
              ' Faulty range
              .Cells(RowInstCrnt, ColInstDestRng).Interior.Color = ClrError  ' Record faulty value
              ErrorOnRow = True
            Else
              ' Convert destination to numbers
              'Debug.Assert False
              ColDest = RngDest.Column
              RowDest = RngDest.Row
            End If
        End Select
      End If

    End With  ' WshtInst

    If Not ErrorOnRow Then

      ' All parameters stored ready for actioning

      RngSrc.Copy Destination:=WshtDest.Cells(RowDest, ColDest)
      DestWbkChanged = True
      ' Extract number of rows and columns from source range in case next
      ' instruction has "destination cell" as A(cross) or D(own)
      NumRowsRngSrc = RngSrc.Rows.Count
      NumColsRngSrc = RngSrc.Columns.Count

    End If

  Next

  If Not WbkSrc Is Nothing Then
    'Debug.Assert False
    WbkSrc.Close SaveChanges:=False
    Set WbkSrc = Nothing
  End If

  If Not WbkDest Is Nothing Then
    Debug.Assert False
    If DestWbkChanged Then
      Debug.Assert False
      WbkSrc.Close SaveChanges:=True
    Else
      Debug.Assert False
      WbkSrc.Close SaveChanges:=False
    End If
    Set WbkDest = Nothing
  End If

End Sub
Public Function ColNum(ByVal ColCode As String) As Long

  ' Checks ColCode is a valid column code for the version of Excel in use
  ' If it is, it returns the equivalent column number.
  ' If it is not, it returns 0.

  ' Coded by Tony Dallimore

  Dim ChrCrnt As String
  Dim ColCodeUc As String:   ColCodeUc = UCase(ColCode)
  Dim Pos As Long

  ColNum = 0

  For Pos = 1 To Len(ColCodeUc)
    ChrCrnt = Mid(ColCodeUc, Pos, 1)
    If ChrCrnt < "A" Or ChrCrnt > "Z" Then
      ColNum = 0
      Exit Function
    End If
    ColNum = ColNum * 26 + Asc(ChrCrnt) - 64
  Next

  If ColNum < 1 Or ColNum > Columns.Count Then
    ColNum = 0
  End If

End Function
Public Function FileExists(ByVal PathName As String, ByVal FileName As String) As Boolean

  ' Returns True if file exists.  Assumes path already tested.

  ' Coded by Tony Dallimore
  ' Based on code written by iDevlop: http://stackoverflow.com/a/28237845/973283

  If Right$(PathName, 1) <> "\" Then
    PathName = PathName & "\"
  End If
  On Error Resume Next
  FileExists = ((GetAttr(PathName & FileName) And vbDirectory) <> vbDirectory)
  On Error GoTo 0

End Function
Public Function PathExists(ByVal PathName As String) As Boolean

  ' Returns True if path exists

  ' Coded by Tony Dallimore
  ' Based on code written by iDevlop: http://stackoverflow.com/a/28237845/973283

  On Error Resume Next
  PathExists = ((GetAttr(PathName) And vbDirectory) = vbDirectory)
  On Error GoTo 0

End Function
Public Function WshtExists(ByRef Wbk As Workbook, ByVal WshtName As String)

  ' Returns True if Worksheet WshtName exists within
  '  * if Wbk Is Nothing the workbook containing the macros
  '  * else workbook Wbk

  ' Coded by Tony Dallimore

  Dim WbkLocal As Workbook
  Dim Wsht As Worksheet

  If Wbk Is Nothing Then
    Set WbkLocal = ThisWorkbook
  Else
    Set WbkLocal = Wbk
  End If

  Err.Clear
  On Error Resume Next
  Set Wsht = WbkLocal.Worksheets(WshtName)
  On Error GoTo 0
  If Wsht Is Nothing Then
    WshtExists = False
  Else
    WshtExists = True
  End If

End Function

Copy a range of data from multiple chosen files

2 Answers2