VBA: Copy a range from all workbooks in a folder to a worksheet in another workbook with workbook na-CodePudding

I want to loop through all the workbooks in a folder, copy data from worksheet "Import fil", column A:CZ starting on row 5 and down to the last active row in column A. Then paste the data as values in another workbook "TOT_Importfiler.xlsm", sheet "Blad1". Data from each new workbook should be pasted on the next empty row in the TOT file. In addition, I want to add the workbook name from each workbook to all the lines from that workbook in column DA in the TOT file so I can track which workbook the data comes from. (Preferably I would want the workbook names in column A and the copied data from the workbooks starting in column B in the TOT file, but adding it at the end works too).

I used a code from another post but I don't know how to add the workbook names. Also it pastes formulas and not values which results in errors when there is a link to another workbook that I don't have access to.

Can anyone help me out?

Sub LoopAllExcelFilesInFolder()

Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim lRow As Long
Dim lRow2 As Long
Dim ws2 As Worksheet
Dim y As Workbook

'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

With FldrPicker
    .Title = "C:\Importfiler test"
    .AllowMultiSelect = False
    If .Show <> -1 Then GoTo NextCode
    myPath = .SelectedItems(1) & "\"
End With

'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings

'Target File Extension (must include wildcard "*")
myExtension = "*.xlsx*"

'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)

Set y = Workbooks.Open("C:\Importfiler test\TOT_Importfiler.xlsm")
Set ws2 = y.Sheets("Blad1")

'Loop through each Excel file in folder
Do While myFile <> ""
    'Set variable equal to opened workbook
    Set wb = Workbooks.Open(Filename:=myPath & myFile)

    'Copy data on "SearchCaseResults" sheet to "Disputes" Sheet in other workbook
    With wb.Sheets("Import fil")
        lRow = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("A5:CZ" & lRow).Copy ws2.Range("A" & Rows.Count).End(xlUp)(2)
        
    End With

    wb.Close SaveChanges:=True
    'Get next file name
    myFile = Dir
Loop

'Message Box when tasks are completed
MsgBox "Task Complete!"

ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

CodePudding user response：

Modify following code line

.Range("A5:CZ" & lRow).Copy ws2.Range("A" & Rows.Count).End(xlUp)(2).PasteSpecial xlPasteValues

to add file name use following code after above line

ws2.Range("A" & Rows.Count).End(xlUp)(2).offset(0,104) = myFile

CodePudding user response：

Import Data From Closed Workbooks

Sub ImportData()

    ' Define constants.
    
    Const PROC_TITLE As String = "Import Data"
    Const SRC_INITIAL_FOLDER_PATH As String = "C:\Importfiler test\"
    Const SRC_FILE_PATTERN As String = "*.xlsx"
    Const SRC_WORKSHEET_NAME As String = "Import Fil"
    Const SRC_FIRST_ROW As String = "A5:CZ5"
    Const DST_FOLDER_PATH As String = "C:\Importfiler test\"
    Const DST_WORKBOOK_NAME As String = "TOT_Importfiler.xlsm"
    Const DST_WORKSHEET_NAME As String = "Blad1"
    Const DST_FIRST_COLUMN As String = "A"

    Dim pSep As String: pSep = Application.PathSeparator
    
    ' Check if the Destination folder and file exist.

    ' Correct.
    Dim dPath As String: dPath = DST_FOLDER_PATH
    If Right(dPath, 1) <> pSep Then dPath = dPath & pSep
    ' Folder
    If Len(Dir(dPath, vbDirectory)) = 0 Then
        MsgBox "The Destination folder '" & dPath & "' doesn't exist.", _
            vbExclamation, PROC_TITLE
        Exit Sub
    End If
    ' File
    Dim dFilePath As String: dFilePath = dPath & DST_WORKBOOK_NAME
    If Len(Dir(dFilePath)) = 0 Then
        MsgBox "The Destination file '" & DST_WORKBOOK_NAME & "' was not " _
            & "found in '" & dPath & "'.", vbExclamation, PROC_TITLE
        Exit Sub
    End If
    
    ' Select the Source folder.
    
    Dim sPath As String: sPath = SRC_INITIAL_FOLDER_PATH
    If Right(sPath, 1) <> pSep Then sPath = sPath & pSep

    Dim FolderDialogCanceled As Boolean
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = sPath
        If .Show Then
            sPath = .SelectedItems(1)
            If Right(sPath, 1) <> pSep Then sPath = sPath & pSep
        Else
            FolderDialogCanceled = True
        End If
    End With
            
    If FolderDialogCanceled Then
        MsgBox "No folder selected.", vbExclamation, PROC_TITLE
        Exit Sub
    End If

    ' Check if there are any files in the Source folder.
    
    Dim sFileName As String: sFileName = Dir(sPath & SRC_FILE_PATTERN)
    If Len(sFileName) = 0 Then
        MsgBox "No Source files found in '" & sPath & "'.", _
            vbExclamation, PROC_TITLE
        Exit Sub
    End If

    ' Reference the Destination objects.
    
    Dim dwb As Workbook: Set dwb = Workbooks.Open(dFilePath)
    
    Dim dws As Worksheet
    On Error Resume Next
        Set dws = dwb.Worksheets(DST_WORKSHEET_NAME)
    On Error GoTo 0
    If dws Is Nothing Then
        MsgBox "The worksheet '" & DST_WORKSHEET_NAME & "' was not found in " _
            & "the workbook '" & DST_WORKBOOK_NAME & "'.", _
            vbExclamation, PROC_TITLE
        Exit Sub
    End If
        
    Dim dfCell As Range
    With dws.UsedRange
        Set dfCell = dws.Cells(.Row   .Rows.Count, DST_FIRST_COLUMN)
    End With

    Dim cCount As Long: cCount = dws.Range(SRC_FIRST_ROW).Columns.Count

    ' Copy the data.
    
    Application.ScreenUpdating = False
    
    Dim swb As Workbook, sws As Worksheet, srg As Range, slCell As Range
    Dim rCount As Long

    Do While Len(sFileName) > 0
        Set swb = Workbooks.Open(sPath & sFileName)
        On Error Resume Next
            Set sws = swb.Worksheets(SRC_WORKSHEET_NAME)
        On Error GoTo 0
        If Not sws Is Nothing Then ' worksheet exists
            If sws.FilterMode Then sws.ShowAllData
            With sws.Range(SRC_FIRST_ROW)
                ' Reference the Source range.
                Set slCell = .Resize(sws.Rows.Count - .Row   1) _
                    .Find("*", , xlFormulas, , , xlPrevious)
                If Not slCell Is Nothing Then ' data in worksheet found
                    rCount = slCell.Row - .Row   1
                    Set srg = .Resize(rCount)
                    ' Copy values.
                    With dfCell.Resize(rCount)
                        .Value = sFileName
                        .Offset(, 1).Resize(, cCount).Value = srg.Value
                    End With
                    Set dfCell = dfCell.Offset(rCount)
                'Else ' no data in worksheet found; do nothing
                End If
            End With
            Set sws = Nothing ' reset for the next iteration
        'Else ' worksheet doesn't exist; do nothing
        End If
        swb.Close SaveChanges:=False ' it was just read from
        sFileName = Dir
    Loop

    Application.ScreenUpdating = True

    ' Inform.
    
    MsgBox "Data imported!", vbInformation, PROC_TITLE

End Sub