Activate Sheet

[PivotMeThis]

I'm still trying to merge a specific sheet from several files into one worksheet. I've been testing different code all morning and I can't find what I need. This code would be ok if I could figure out how to activate a specific sheet in each of the files I'm trying to copy. This would be sheet3 or MAP.

I've tried adjusting the code and inserting additional code (trying to activate sheet3 or MAP) but I always break it.

Can anyone help me?
Thanks

Sub MergeExcelFiles()
Dim firstRowHeaders As Boolean
    Dim fso As Object
    Dim dir As Object
    Dim filename As Variant
    Dim wb As Workbook
    Dim s As Sheet1
    Dim thisSheet As Sheet1
    Dim lastUsedRow As Range
    Dim file As String
    
On Error GoTo ErrMsg
 
    Application.ScreenUpdating = False
    firstRowHeaders = True 'Change from True to False if there are no headers in the first row
 
    Set fso = CreateObject("Scripting.FileSystemObject")
 
    'PLEASE NOTE: Change <<Full path to your Excel files folder>> to the path to the folder containing your Excel files to merge
    Set dir = fso.Getfolder("W:\Highway\Construction\Staff\Senior Engineering Technician - Rhonda\TEST")
 
    Set thisSheet = ThisWorkbook.ActiveSheet
    
    For Each filename In dir.Files
        'Open the spreadsheet in ReadOnly mode
        Set wb = Application.Workbooks.Open(filename, ReadOnly:=True)
        
        'Copy the used range (i.e. cells with data) from the opened spreadsheet
        If firstRowHeaders And i > 0 Then 'Only include headers from the first spreadsheet
            Dim mr As Integer
            mr = wb.ActiveSheet.UsedRange.Rows.Count
            wb.ActiveSheet.UsedRange.Offset(1, 0).Resize(mr - 1).Copy
        Else
            wb.ActiveSheet.UsedRange.Copy
        End If
          
         'Paste after the last used cell in the master spreadsheet
        If Application.Version < "12.0" Then 'Excel 2007 introduced more rows
            Set lastUsedRow = thisSheet.Range("A65536").End(xlUp)
        Else
            Set lastUsedRow = thisSheet.Range("A1048576").End(xlUp)
        End If
        
        'Only offset by 1 if there are current rows with data in them
        If thisSheet.UsedRange.Rows.Count > 1 Or Application.CountA(thisSheet.Rows(1)) Then
            Set lastUsedRow = lastUsedRow.Offset(1, 0)
        End If
        lastUsedRow.PasteSpecial
        Application.CutCopyMode = False
    Next filename
    
    ThisWorkbook.Save
    Set wb = Nothing
    
    #If Mac Then
        'Do nothing. Closing workbooks fails on Mac for some reason
    #Else
        'Close the workbooks except this one
        For Each filename In dir.Files
            file = Right(filename, Len(filename) - InStrRev(filename, Application.PathSeparator, , 1))
            Workbooks(file).Close SaveChanges:=False
        Next filename
    #End If
    
    Application.ScreenUpdating = True
ErrMsg:
    If Err.Number <> 0 Then
        MsgBox "There was an error. Please try again. [" & Err.Description & "]"
    End If
End Sub

 

[Jerry Sullivan]

Hi Rhonda,

You can copy the data without Activating the Worksheet by referencing it directly.

Assuming that you know there will be a Sheet "MAP" in each workbook, you could modify this part.

   With wb.Sheets("MAP").UsedRange
      'Copy the used range (i.e. cells with data) from the opened spreadsheet
      If firstRowHeaders And i > 0 Then
         'Only include headers from the first spreadsheet
        .Offset(1, 0).Resize(.Rows.Count - 1).Copy
      Else
        .UsedRange.Copy
      End If
   End With

I didn't follow what you meant by "This would be sheet3 or MAP."
Could there be either one or both of those named sheets in the same workbook?

If so I can suggest some code to test for which exists in each workbook.

 

[PivotMeThis]

I should have said MAP (aka Sheet3). They are one in the same and the files all say MAP. This used to be a single file but because field staff found that the file was sometimes locked by someone else when they wanted to use it, it had to be split into 6 files. And that's why I'm looking for this code to put it back together every week for another user who requires a single file of the data that resides on the MAP tab.

This code stopped working when it opened the first file because of the code that resides in the 6 files that I want to copy.

Private Sub Workbook_Open()
    Worksheets("ProjectData").Activate
End Sub

The code that resides in these 6 workbooks, first always opens the file to the ProjectData tab so that field staff does not accidently fill out the wrong sheet. Other code is attached to buttons on the ProjectData sheet that is used by the editor when she has finished editing. One copies specific rows to the MAP tab and the other changes the font back to black. These 3 pieces of code all reside in "ThisWorkbook". There is more code in "ProjectData", the first changes the font color if it has been changed and the second hides a couple of buttons that are attached to some of the code in ThisWorksheet.

Not sure you needed to know all that but thought it was worth sharing. Is there a way to temporarily turn off the code in the file when it is opened and then turned back on when it is closed? Or something like that...I spent all day yesterday trying to find something to make this work and it seems like I saw something like that somewhere but I have no idea where it was now or if it would even work.

One more thought - since I'm talking to my hero Is there a way to clear the sheet each week before the new data is copied to the file?

It's always so nice to hear from you Jerry
Thanks for your help

 

[PivotMeThis]

P.S. I tried Application.EnableEvents false before open and true after copy but it did not work. Not sure if I put it in the wrong place or it's just the wrong thing to use.

 

[PivotMeThis]

I've been playing around with this trying to get it to work and here's my new code that still isn't working but closer.

A friend with a lot more experience than I stopped by and found

If firstRowHeaders And i > 0 Then

and said the i was not declared and not found anywhere else. He added Dim i As Integer just to get the code moving and said it wasn't really doing anything.

He said something about Dim firstRowHeaders As Boolean but I don't really understand or remember what that was.

He also changed UsedRange.Copy to .Copy because it was already using that in a line above.

After that the code ran and copied all the information from the map tab but it copied the header row from every file.

Sub MergeExcelFiles()
Dim firstRowHeaders As Boolean
    Dim fso As Object
    Dim dir As Object
    Dim filename As Variant
    Dim wb As Workbook
    Dim s As Sheet1
    Dim thisSheet As Sheet1
    Dim lastUsedRow As Range
    Dim file As String
    Dim i As Integer
    
On Error GoTo ErrMsg
 
    Application.ScreenUpdating = False
    firstRowHeaders = True 'Change from True to False if there are no headers in the first row
 
    Set fso = CreateObject("Scripting.FileSystemObject")
 
    'PLEASE NOTE: Change <> to the path to the folder containing your Excel files to merge
    Set dir = fso.Getfolder("W:\Highway\Construction\Staff\Senior Engineering Technician - Rhonda\TEST")
 
    Set thisSheet = ThisWorkbook.ActiveSheet
    
    For Each filename In dir.Files
        'Open the spreadsheet in ReadOnly mode
        Set wb = Application.Workbooks.Open(filename, ReadOnly:=True)
        
        With wb.Sheets("MAP").UsedRange
            'Copy the used range (i.e. cells with data) from the opened spreadsheet
            If firstRowHeaders And i > 0 Then
               'Only include headers from the first spreadsheet
              .Offset(1, 0).Resize(.Rows.Count - 1).Copy
            Else
              '.UsedRange.Copy
              .Copy
            End If
        End With
   
         'Paste after the last used cell in the master spreadsheet
        If Application.Version < "12.0" Then 'Excel 2007 introduced more rows
            Set lastUsedRow = thisSheet.Range("A65536").End(xlUp)
        Else
            Set lastUsedRow = thisSheet.Range("A1048576").End(xlUp)
        End If
        
        'Only offset by 1 if there are current rows with data in them
        If thisSheet.UsedRange.Rows.Count > 1 Or Application.CountA(thisSheet.Rows(1)) Then
            Set lastUsedRow = lastUsedRow.Offset(1, 0)
        End If
        lastUsedRow.PasteSpecial
        Application.CutCopyMode = False
    Next filename
    
    ThisWorkbook.Save
    Set wb = Nothing
    
    #If Mac Then
        'Do nothing. Closing workbooks fails on Mac for some reason
    #Else
        'Close the workbooks except this one
        For Each filename In dir.Files
            file = Right(filename, Len(filename) - InStrRev(filename, Application.PathSeparator, , 1))
            Workbooks(file).Close SaveChanges:=False
        Next filename
    #End If
    
    Application.ScreenUpdating = True
ErrMsg:
    If Err.Number <> 0 Then
        MsgBox "There was an error. Please try again. [" & Err.Description & "]"
    End If
End Sub

I still need to copy the header only from the first file.

If possible, delete the data from the merged report when it is ran in the future. What I mean to say is, the report has been run and contains the merged information. Next week the report needs to be run again, so delete the used rows from the merged spreadsheet before running the macro to copy all the files again.

Then there's the BIG dream. Resize columns and rows to match original files. (Files being copies from).

 

[Jerry Sullivan]

Hi Rhonda,

Your friend is right, that variable "i" wasn't doing anything.

I've reworked the procedure to address your comments.

You'll need to change "MasterMAP" to match your actual sheet name.

Sub MergeExcelFiles()
 Dim bIsFirstBook As Boolean
 Dim bHasHeaders As Boolean
 Dim fso As Object
 Dim dir As Object
 Dim rLastUsedRow As Range
 Dim sErrMsg As String
 Dim filename As Variant
 Dim wb As Workbook
 Dim wksMasterSheet As Worksheet
   
 On Error GoTo ErrMsg
 
 Application.ScreenUpdating = False
 Application.EnableEvents = False
 
 bHasHeaders = True 'False if there are no headers in first row

 Set fso = CreateObject("Scripting.FileSystemObject")
 '--folder containing your Excel files to merge
 Set dir = fso.Getfolder( _
   "W:\Highway\Construction\Staff\Senior Engineering Technician - Rhonda\TEST")

 Set wksMasterSheet = ThisWorkbook.Sheets("MasterMAP")

 '--clear previous data
 wksMasterSheet.UsedRange.ClearContents
 
 '--initial value. will be made False at end of first loop
 bIsFirstBook = True
 
 For Each filename In dir.Files
   'Open the spreadsheet in ReadOnly mode
   Set wb = Application.Workbooks.Open(filename, ReadOnly:=True)
       
   With wb.Sheets("MAP").UsedRange
      If bHasHeaders And bIsFirstBook Then
         '--copy headers with formatting
         .Resize(1).Copy Destination:=wksMasterSheet.Cells(1)
      End If
      .Offset(-1 * bHasHeaders).Resize(.Rows.Count + bHasHeaders).Copy
      bIsFirstBook = False
   End With

   With wksMasterSheet
      Set rLastUsedRow = .Cells.Find("*", LookIn:=xlValues, SearchOrder:=xlByRows, _
         SearchDirection:=xlPrevious, SearchFormat:=False)
         
      If rLastUsedRow Is Nothing Then
         .Cells(1).PasteSpecial (xlPasteValues)
      Else
         .Cells(rLastUsedRow.Row + 1, "A").PasteSpecial (xlPasteValues)
      End If
   End With
   
   #If Mac Then
      'Do nothing. Closing workbooks fails on Mac for some reason
   #Else
      wb.Close SaveChanges:=False
   #End If
    
 Next filename
    
 '--apply final formatting
 With wksMasterSheet.UsedRange
   .EntireRow.AutoFit
   .EntireColumn.AutoFit
   .Cells(1).Select
 End With
 
 ThisWorkbook.Save
 
ExitProc:
 On Error Resume Next
 Application.ScreenUpdating = True
 Application.EnableEvents = True
 Application.CutCopyMode = False
 If Len(sErrMsg) Then MsgBox sErrMsg
 Exit Sub

ErrMsg:
 sErrMsg = "There was an error. Please try again. [" & Err.Description & "]"
 Resume ExitProc
End Sub

I'm not sure exactly what you wanted here.

Resize columns and rows to match original files. (Files being copies from).

I added a simple AutoFit step in the suggested code.
If you are gathering the data from many users, I'd think you would want to have the formatting applied uniformly to the master instead of it being dependent on the user's copy.

The code can be modified if that's really what you want.

 

[PivotMeThis]

Thanks Jerry! This is working great execpt for the clipboard messages. Each time one of the six files is closed it pops up asking if I want to save what is on the clipboard. I thought turning off screen updating would fix that. ??

I like the way the AutoFit works.

 

[Jerry Sullivan]

Rhonda, You can temporarily disable alerts at the beginning of the code with:

Application.DisplayAlerts=False

Reset it to True at the end of the code with the other settings.

 

[PivotMeThis]

AH! Thanks, I got that mixed up with one of the others. (Screen updating - silly me )

You are the best, I really appreciate your help with this! If you were closer I'd buy you dinner!!! (In these parts that's lunch )