excel vba for open, copy multiple workbooks then paste all in a new workbook sheet1

[jhae]

Hi can somebody please help me create macro for I want to open multiple workbooks (all are save in the same folder), copy all data from sheet1 of each workbook and paste it in a new workbook. On the new workbook sheet1, data of workbook1 will be paste then on its last row follows data of workbook2 and so on. After copying all data all workbook must be closed except the new workbook and the workbook that contains the macro.

 

[robmaag]

Phil,

The reason why I created the asterisk in the following code (see below):

myArr(1) = Workbooks("ALLIED PACIFIC OF CALIF*").Name
myArr(2) = Workbooks("ALPHA MSO*").Name
myArr(3) = Workbooks("AMM*").Name
myArr(4) = Workbooks("ANCHOR MEDICAL*").Name

because I am not sure if this is the correct full name of the excel workbook...I thought by putting the * at the end it would act as a wildcard to find a match of excel files that emulate this file name

The Source Workbooks only have 1 worksheet in each.
The Target Workbooks have a number of worksheets in each

In so far as the placement, the Source Workbook copied should be placed as the 'first' worksheet in Report-A

Everything else is correct...

The idea is to create a loop statement that loops through all the excel files in the folder and perform that task...

Your thoughts...

Robert

I
was

 

[pbornemeier]

This approach should work as long as all of the target worksheets start with "Report-" and the rest of the target names matches the source name.

Option Explicit

Sub UpdateReportWorksheets()

    Const bExt As Boolean = False    'Set True if extension should be part of comparison between Source and Target FileNameExt
    
    Dim sPath As String
    Dim oFile As Object, x As Long
    Dim aryFiles() As Variant, lFileIndex As Long
    Dim sSourceFileName As String, lSFIndex As Long
    Dim sTargetFileName As String, lTFIndex As Long
    Dim sChunk As String
    Dim sSCheck As String
    
    ThisWorkbook.Activate
    
    AddAndNameReportSheet
    
    sPath = "C:\Report"
  
    'Create File Array of all files in sPath
    For Each oFile In CreateObject("scripting.filesystemobject").GetFolder(sPath).Files
      lFileIndex = lFileIndex + 1: ReDim Preserve aryFiles(1 To lFileIndex): aryFiles(lFileIndex) = oFile.Name
    Next
    
    'Find each Target File (Starts with Report-)
    For lTFIndex = LBound(aryFiles) To UBound(aryFiles)
      If Left(aryFiles(lTFIndex), 7) = "Report-" Then
        sTargetFileName = aryFiles(lTFIndex)
        'Find Corresponding Source File
        
        sChunk = Mid(sTargetFileName, 8, InStrRev(sTargetFileName, ".") - 8)
        If bExt Then sChunk = Mid(sTargetFileName, 8)
        
        For lSFIndex = LBound(aryFiles) To UBound(aryFiles)
          sSourceFileName = aryFiles(lSFIndex)
          sSCheck = Left(sSourceFileName, InStrRev(sSourceFileName, ".") - 1) 'If you want to ignore extension
          If bExt Then sSCheck = aryFiles(lSFIndex)
          If sSCheck = sChunk Then
            Exit For
          Else
            sSourceFileName = vbNullString
          End If
        Next
        If sSourceFileName <> vbNullString Then
          'Open target files and copy worksheets
          Workbooks.Open fileName:=sPath & "\" & sTargetFileName
          Workbooks.Open fileName:=sPath & "\" & sSourceFileName, ReadOnly:=True
          Sheets(1).Copy Before:=Workbooks(sTargetFileName).Sheets(1)
          'Close files
          Workbooks(sTargetFileName).Close SaveChanges:=True  'Save Target
          Workbooks(sSourceFileName).Close SaveChanges:=False
          AddToReport "Updated " & sTargetFileName & " from " & sSourceFileName
        Else
          AddToReport "No matching source file for " & sTargetFileName
        End If
      End If
    Next
    
    Application.StatusBar = False
    
End Sub

Sub AddAndNameReportSheet()

    Dim sWorksheet As String
    
    sWorksheet = "Report"
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets(sWorksheet).Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    Worksheets.Add(Before:=Sheets(1)).Name = sWorksheet 'After last
    
End Sub

Sub AddToReport(sItem As String)

    Dim lNextReportWriteRow As Long
    
    With ThisWorkbook.Worksheets("Report")
        lNextReportWriteRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        .Cells(lNextReportWriteRow, 1).Value = Now()
        .Cells(lNextReportWriteRow, 2).Value = sItem
    End With
    Application.StatusBar = sItem
    DoEvents
    
End Sub

 

[robmaag]

Phil, this is great and I will test this out but the source names start with 'IPA'...do the source names and target names (aside from Report) need to be equal? If so, could the code by modified so that the source name starts with 'IPA' and the Target name starts with 'Report'...basically I am attempting to get close matches between the source and target names...that is why I used wildcards...Your thoughts...this is great...believe me

 

[robmaag]

Phil, I have another problem. I get a run time error 1004 'Excel cannot insert the sheets into destination workbook beacuse it contains fewer rows and columns that the source workbook. To move or copy the data to the destination workbook you can select the data and thn use the .xls the copy paste comands to insert the sheets...The code is hanging on the line ' Sheets(1).Copy Before:=Workbooks(sTargetFileName).Sheets(1)' The source files extensions are .xlsx and the targe file extensions are .xls...Please help...I don't know what to do?

 

[pbornemeier]

The problem is that the pages that you are copying will not fit in the old workbook format.
There are two options.
1) Open and convert all of the target workbooks, either manually or with additional code as needed.
2) If you are not using the rows and columns outside the limits of the target worksheet, add an new worksheet at the front of the target workbook and only copy the used range of the source worksheet.

You could use the Like function with wildcards to do the matching, but you would never know for sure if all of the worksheets were going unless you created a test run that compared your source and target workbooks that were paired by the like function and then personally visually checked that the matches were what you wanted.