Open and Copy last Row of All Files in Folder Then Paste to Master

[Super P]

Code below - copy the last 2 rows data of each workbook files in a folder then paste it all to Master workbook.

Problem 1 - can someone help on how get the codes below copy only the last row of each workbook.

Problem 2 - instead of copying from Col A to last Column of Data, I want to copy only specific columns e.g. Columns A to F, J and M.

Appreciate any help thanks.

Option Explicit

Sub OpenEachFiles_CopyLastRow_PasteToMaster()

Dim fso, fldr, fName As Object, Cnt, Cnt2, Cnt3, Cnt4, lRow, lCol As Long
Dim ws As Worksheet, rngArray() As Variant, rng As Range

    On Error GoTo Errorfix

    Cnt2 = 1 'dimension array
    Cnt3 = 0 'array positions

    Set fso = CreateObject("scripting.filesystemobject")
    Set fldr = fso.GetFolder("C:\Users\Tope\Desktop\Data")

    For Each fName In fldr.files
       
        If fName.Name Like "*.xls*" Then
            Workbooks.Open Filename:=fName
           
            For Each ws In Workbooks(fName.Name).Sheets
               
                If LCase(ws.Name) = LCase("Data") Then
                   
                    With Sheets("Data")
                        lRow = .Range("A" & .Rows.Count).End(xlUp).Row
                        lCol = .Cells(lRow, .Columns.Count).End(xlToLeft).Column
                    End With

                    Cnt2 = Cnt2 + 1

                    ReDim Preserve rngArray(Cnt2)

                    With Workbooks(fName.Name).Sheets(ws.Name)
                        Set rng = .Range(.Cells(lRow - 1, 1), .Cells(lRow, lCol))
                    End With

                    rngArray(Cnt3) = rng
                    Cnt3 = Cnt3 + 1
                  
                End If

            Next ws

                Workbooks(fName.Name).Close SaveChanges:=False

        End If
   
    Next fName

    Cnt = 2
    For Cnt4 = 0 To Cnt3 - 1
       
        With ThisWorkbook.Sheets("Master")
            .Range(.Cells(Cnt, "A"), .Cells(Cnt + 1, lCol)) = rngArray(Cnt4)
        End With
       
        Cnt = Cnt + 2
   
    Next Cnt4

Errorfix:
    If Err.Number <> 0 Then
       
        On Error GoTo 0
        MsgBox "Error"
   
    End If

Set fldr = Nothing
Set fso = Nothing
 
End Sub

 

[DanteAmor]

Try this:

Adjust the name of the folder and the name of the sheet from which you want to get the information.

Copy all code including the HasSheet function into a module and run the CopyLastRow_ToMaster macro.

Sub CopyLastRow_ToMaster()
  Dim fso As Object, fldr As Object, fName As Object
  Dim sh1 As Worksheet
  Dim wb2 As Workbook
  Dim lr1 As Long, lr2 As Long
  Dim filePath As String, sheetName As String

  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  Set sh1 = ThisWorkbook.Sheets("Master")
  filePath =  "C:\Users\Tope\Desktop\Data"
  sheetName = "Data"

  Set fso = CreateObject("scripting.filesystemobject")
  Set fldr = fso.GetFolder(filePath)
  
  lr1 = sh1.Range("A" & Rows.Count).End(3).Row + 1
  For Each fName In fldr.Files
    If fName.Name Like "*.xls*" Then
      If HasSheet(filePath, fName.Name, sheetName) Then
        Set wb2 = Workbooks.Open(fName, , True)
        With wb2.Sheets(sheetName)
          lr2 = .Range("A" & Rows.Count).End(3).Row
          .Range("A" & lr2 & ":F" & lr2 & ",J" & lr2 & ",M" & lr2).Copy
          sh1.Range("A" & lr1).PasteSpecial xlPasteValues
          lr1 = lr1 + 1
        End With
        wb2.Close False
      End If
    End If
  Next
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

Function HasSheet(fPath As String, fName As String, sheetName As String)
  Dim f As String
  f = "'" & fPath & "\[" & fName & "]" & sheetName & "'!R1C1"
  HasSheet = Not IsError(Application.ExecuteExcel4Macro(f))
End Function

 

[Super P]

Try this:

Adjust the name of the folder and the name of the sheet from which you want to get the information.

Copy all code including the HasSheet function into a module and run the CopyLastRow_ToMaster macro.

Sub CopyLastRow_ToMaster()
  Dim fso As Object, fldr As Object, fName As Object
  Dim sh1 As Worksheet
  Dim wb2 As Workbook
  Dim lr1 As Long, lr2 As Long
  Dim filePath As String, sheetName As String

  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
 
  Set sh1 = ThisWorkbook.Sheets("Master")
  filePath =  "C:\Users\Tope\Desktop\Data"
  sheetName = "Data"

  Set fso = CreateObject("scripting.filesystemobject")
  Set fldr = fso.GetFolder(filePath)
 
  lr1 = sh1.Range("A" & Rows.Count).End(3).Row + 1
  For Each fName In fldr.Files
    If fName.Name Like "*.xls*" Then
      If HasSheet(filePath, fName.Name, sheetName) Then
        Set wb2 = Workbooks.Open(fName, , True)
        With wb2.Sheets(sheetName)
          lr2 = .Range("A" & Rows.Count).End(3).Row
          .Range("A" & lr2 & ":F" & lr2 & ",J" & lr2 & ",M" & lr2).Copy
          sh1.Range("A" & lr1).PasteSpecial xlPasteValues
          lr1 = lr1 + 1
        End With
        wb2.Close False
      End If
    End If
  Next
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

Function HasSheet(fPath As String, fName As String, sheetName As String)
  Dim f As String
  f = "'" & fPath & "\[" & fName & "]" & sheetName & "'!R1C1"
  HasSheet = Not IsError(Application.ExecuteExcel4Macro(f))
End Function

@DanteAmor that works great!!

 

[Super P]

Try this:

Adjust the name of the folder and the name of the sheet from which you want to get the information.

Copy all code including the HasSheet function into a module and run the CopyLastRow_ToMaster macro.

Sub CopyLastRow_ToMaster()
  Dim fso As Object, fldr As Object, fName As Object
  Dim sh1 As Worksheet
  Dim wb2 As Workbook
  Dim lr1 As Long, lr2 As Long
  Dim filePath As String, sheetName As String

  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
 
  Set sh1 = ThisWorkbook.Sheets("Master")
  filePath =  "C:\Users\Tope\Desktop\Data"
  sheetName = "Data"

  Set fso = CreateObject("scripting.filesystemobject")
  Set fldr = fso.GetFolder(filePath)
 
  lr1 = sh1.Range("A" & Rows.Count).End(3).Row + 1
  For Each fName In fldr.Files
    If fName.Name Like "*.xls*" Then
      If HasSheet(filePath, fName.Name, sheetName) Then
        Set wb2 = Workbooks.Open(fName, , True)
        With wb2.Sheets(sheetName)
          lr2 = .Range("A" & Rows.Count).End(3).Row
          .Range("A" & lr2 & ":F" & lr2 & ",J" & lr2 & ",M" & lr2).Copy
          sh1.Range("A" & lr1).PasteSpecial xlPasteValues
          lr1 = lr1 + 1
        End With
        wb2.Close False
      End If
    End If
  Next
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

Function HasSheet(fPath As String, fName As String, sheetName As String)
  Dim f As String
  f = "'" & fPath & "\[" & fName & "]" & sheetName & "'!R1C1"
  HasSheet = Not IsError(Application.ExecuteExcel4Macro(f))
End Function

@DanteAmor, sorry for asking stupid question as I am fairly new in VBA, can you please advise what is 3 in .End(3)?

 

[DanteAmor]

Do not worry, you have doubts and it is right to ask.

The Range.End method is very similar to pressing the Ctrl+Arrow Key keyboard shortcut. In VBA we can use this method to find the last non-blank cell in a single row or column.

Values can be:
1 xlToLeft
2 xlToRight
3 xlUp
4 xlDown

To find the last row with data and thus the next available row, you can use:
lr1 = sh1.Range("A" & Rows.Count).End(3).Row + 1
or
lr1 = sh1.Range("A" & Rows.Count).End(xlUp).Row + 1
or
lr1 = sh1.Range("A" & Rows.Count).End(3)(2).Row

And there are other ways, but those are the most common.

 

[Super P]

Do not worry, you have doubts and it is right to ask.

The Range.End method is very similar to pressing the Ctrl+Arrow Key keyboard shortcut. In VBA we can use this method to find the last non-blank cell in a single row or column.

Values can be:
1 xlToLeft
2 xlToRight
3 xlUp
4 xlDown

To find the last row with data and thus the next available row, you can use:
lr1 = sh1.Range("A" & Rows.Count).End(3).Row + 1
or
lr1 = sh1.Range("A" & Rows.Count).End(xlUp).Row + 1
or
lr = Range("A" & Rows.Count).End(3)(2).Row

And there are other ways, but those are the most common.

@DanteAmor thanks!

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.