VBA Open selected file and merge the data to a new file-CodePudding

I'm having issues getting data from multiple selected files (.xlxs) then merging this and copying all into another selected xlxs file.

The data in the selected files have unknown amounts of columns and unknown rows start at row 2 (to not take the header) The data must be paste in the new file starting at row 2 aswell.

here is my current code:

Sub Test()

    Dim sourceFile As Variant, destinationFile As String
    Dim sourceSheet As Worksheet, destinationSheet As Worksheet
    Dim destinationWorkbook As Workbook
    


    sourceFile = Application.GetOpenFilename(FileFilter:="Excel Files (*.xlsx), *.xlsx", MultiSelect:=True)
    ' Check if the user selected any files
    If IsArray(sourceFile) Then
        ' Loop through all selected file names
        For I = LBound(sourceFile) To UBound(sourceFile)
            ' Open the current file
            Workbooks.Open sourceFile(I)
            Debug.Print sourceFile(I)
            'copy data
            

        Next I
    End If

    ' Open the destination file
    destinationFile = Application.GetOpenFilename(FileFilter:="Excel Files (*.xlsx), *.xlsx", MultiSelect:=False)
    ' Paste data

End Sub

I don't see how i can copy the date and get it together

CodePudding user response：

Backup Data

It will open each selected file and write the data into an array before closing the file.
Then it will open the selected destination file and write the data to it before saving and closing it.
Adjust the destination worksheet name or index DST_WORKSHEET_ID since it was never discussed.

Option Explicit

Sub BackupData()
  
    ' Define constants.
    
    Const SRC_WORKSHEET_ID As Variant = 1 ' name or index e.g. "Sheet1" or 1
    Const DST_WORKSHEET_ID As Variant = 1 ' name or index e.g. "Sheet1" or 1
    Const DST_FIRST_CELL As String = "A2"
    
    ' Read the Source data into an array ('sJag').
    
    Dim sPaths: sPaths = Application.GetOpenFilename( _
        FileFilter:="Excel Files (*.xlsx), *.xlsx", _
        MultiSelect:=True)
    
    If VarType(sPaths) = vbBoolean Then
        MsgBox "No files selected.", vbExclamation
        Exit Sub
    End If
    
    Dim sCount As Long: sCount = UBound(sPaths)
    Dim sJag(): ReDim sJag(1 To sCount, 1 To 3)
    
    Application.ScreenUpdating = False
    
    Dim swb As Workbook, sws As Worksheet, srg As Range, sData(), sn As Long
    Dim srCount As Long, scCount As Long
    
    For sn = 1 To sCount
        Set swb = Workbooks.Open(sPaths(sn), True, True)
        Set sws = swb.Worksheets(SRC_WORKSHEET_ID)
        Set srg = sws.UsedRange
        srCount = srg.Rows.Count - 1
        scCount = srg.Columns.Count
        If srCount > 0 Then
            Set srg = srg.Resize(srg.Rows.Count - 1).Offset(1)
            If srCount * scCount = 1 Then
                ReDim sData(1 To 1, 1 To 1): sData(1, 1) = srg.Value
            Else
                sData = srg.Value
            End If
            sJag(sn, 1) = sData ' data
            sJag(sn, 2) = srCount ' rows
            sJag(sn, 3) = scCount ' columns
        End If
        swb.Close SaveChanges:=False
    Next sn
    
    Erase sData
    
    ' Reference the first Destination cell ('dfCell').
    
    Dim dPath: dPath = Application.GetOpenFilename( _
        FileFilter:="Excel Files (*.xlsx), *.xlsx", _
        MultiSelect:=False)

    If VarType(dPath) = vbBoolean Then
        MsgBox "No file selected.", vbCritical
        Exit Sub
    End If
    
    Dim dwb As Workbook: Set dwb = Workbooks.Open(dPath)
    Dim dws As Worksheet: Set dws = dwb.Worksheets(DST_WORKSHEET_ID)
    If dws.FilterMode Then dws.ShowAllData
    Dim dfCell As Range: Set dfCell = dws.Range(DST_FIRST_CELL)
    
    With dfCell
        Dim dlCell As Range: Set dlCell = .Resize( _
            dws.Rows.Count - .Row   1, dws.Columns.Count - .Column   1) _
                .Find(What:="*", LookIn:=xlFormulas, _
                    SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
        If Not dlCell Is Nothing Then
            Set dfCell = .Offset(dlCell.Row - .Row   1)
        End If
    End With
    
    ' Write the Source data to the Destination worksheet.
    
    For sn = 1 To sCount
        If Not IsEmpty(sJag(sn, 1)) Then
            dfCell.Resize(sJag(sn, 2), sJag(sn, 3)).Value = sJag(sn, 1)
            Set dfCell = dfCell.Offset(sJag(sn, 2))
        End If
    Next sn
    
    dwb.Close SaveChanges:=True
    
    ' Inform.
    
    Application.ScreenUpdating = True
    
    MsgBox "Backup completed.", vbInformation

End Sub

CodePudding user response：

So you basically needed a reference to the workbook. Something like this should work for you (tested):

Sub Test4()

    Dim sourceFile As Variant, destinationFile As String
    Dim sourceSheet As Worksheet, destinationSheet As Worksheet
    Dim destinationWorkbook As Workbook, wb As Workbook
    Dim lRow As Long
    

    ' Open the destination file
    destinationFile = Application.GetOpenFilename(FileFilter:="Excel Files (*.xlsx), *.xlsx", MultiSelect:=False)
    Set destinationWorkbook = Workbooks.Open(destinationFile)
    Set destinationSheet = destinationWorkbook.Sheets(1)
    
    sourceFile = Application.GetOpenFilename(FileFilter:="Excel Files (*.xlsx), *.xlsx", MultiSelect:=True)
    ' Check if the user selected any files
    If IsArray(sourceFile) Then
        ' Loop through all selected file names
        Application.DisplayAlerts = False
        For i = LBound(sourceFile) To UBound(sourceFile)
            ' Open the current file
            Set wb = Workbooks.Open(sourceFile(i))
            Debug.Print wb.Name
            Set sourceSheet = wb.Sheets(1)
            sourceSheet.Range("A2:A" & sourceSheet.Range("A" & Rows.Count).End(xlUp).Row).EntireRow.Copy 'copy data
            lRow = destinationSheet.Range("A" & Rows.Count).End(xlUp).Row   1
            destinationSheet.Range("A" & lRow).PasteSpecial xlPasteValues
            wb.Close (False) 'close source workbook
        Next i
        Application.DisplayAlerts = True
        Application.CutCopyMode = False
    End If

End Sub

Or if you want to get the values without using Clipboard, see Scott Craner's answer for a more in-depth explanation:

Sub Test5()

    Dim sourceFile As Variant, destinationFile As String
    Dim sourceSheet As Worksheet, destinationSheet As Worksheet
    Dim destinationWorkbook As Workbook, wb As Workbook
    Dim lRowD As Long, lRowS As Long, lCol As Long
    

    ' Open the destination file
    destinationFile = Application.GetOpenFilename(FileFilter:="Excel Files (*.xlsx), *.xlsx", MultiSelect:=False)
    Set destinationWorkbook = Workbooks.Open(destinationFile)
    Set destinationSheet = destinationWorkbook.Sheets(1)
    
    sourceFile = Application.GetOpenFilename(FileFilter:="Excel Files (*.xlsx), *.xlsx", MultiSelect:=True)
    ' Check if the user selected any files
    If IsArray(sourceFile) Then
        ' Loop through all selected file names
        Application.DisplayAlerts = False
        For i = LBound(sourceFile) To UBound(sourceFile)
            ' Open the current file
            Set wb = Workbooks.Open(sourceFile(i))
            Debug.Print wb.Name
            Set sourceSheet = wb.Sheets(1)
            With sourceSheet
                lCol = .Cells(1, Columns.Count).End(xlToLeft).Column
                lRowS = .Range("A" & Rows.Count).End(xlUp).Row
            End With
            With destinationSheet
                lRowD = .Cells(.Rows.Count, 1).End(xlUp).Row   1
                .Cells(lRowD, 1).Resize(lRowS - 1, lCol).Value2 = sourceSheet.Cells(2, 1).Resize(lRowS, lCol).Value2 'copy data
            End With
            wb.Close (False) 'close source workbook
        Next i
        Application.DisplayAlerts = True
        Application.CutCopyMode = False
    End If

End Sub

If you have any more questions, feel free to ask :)