Drop Down MenusCSS Drop Down MenuPure CSS Dropdown Menu

Thursday 31 March 2016

How to consolidate two or more Workbook into a Worksheet using Macro

Public Function IsFileOpen(strFileName As String) As Boolean
   
    On Error Resume Next 'Ignore any errors (i.e. if workbook is not open)
   
        Set wrkFileName = Workbooks(strFileName)
       
            If wrkFileName Is Nothing Then
                IsFileOpen = False
            Else
                IsFileOpen = True
            End If
           
    On Error GoTo 0 'Nullify above error handler
   
End Function
Sub ConsolidateInSingleSheet()

    Dim strDir As String, _
        strThisWkb As String, _
        strConsTab As String
    Dim objFSO As Object, _
        objFolder As Object, _
        objFile As Object
    Dim lngPasteRow As Long
   
    strDir = "D:\Source Excel" ' can be Change
    strThisWkb = ThisWorkbook.Name
    strConsTab = "Sheet1" ' can be Change
   
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFSO.GetFolder(strDir)
   
    Application.ScreenUpdating = False
     
    'Clear any existing data.
    lngPasteRow = Workbooks(strThisWkb).Sheets(strConsTab).Cells(Rows.Count, "A").End(xlUp).Row
    Workbooks(strThisWkb).Sheets(strConsTab).Range("A1:Z" & lngPasteRow).ClearContents
   
    For Each objFile In objFolder.Files
        'If the file in the 'strDir' directory is not this workbook, then...
        Dim LastrowDes As Double
        Dim rowCountSource As Double
        If objFile.Name <> strThisWkb Then
            '...check to see if it's open.  If it is...
            If IsFileOpen(objFile.Name) = True Then
            LastrowDes = Workbooks(strThisWkb).Sheets(strConsTab).Cells(Rows.Count, "A").End(xlUp).Row
            rowCountSource = Workbooks(objFile.Name).Sheets(4).Cells(Rows.Count, "A").End(xlUp).Row
                '...set the 'lngPasteRow' variable.  If this value is 2, then...
                lngPasteRow = _
                    Workbooks(strThisWkb).Sheets(strConsTab).Cells(Rows.Count, "A").End(xlUp).Row + 1
                        If lngPasteRow = 2 Then
                            '...link the entire range (i.e. headings + data) as this is the first file being imported.
                            Workbooks(strThisWkb).Sheets(strConsTab).Range("A1:Z" & rowCountSource).Value = _
                            Workbooks(objFile.Name).Sheets(4).Range("A1:Z" & rowCountSource).Value 'Link workbook only has 1 tab.
                            'Else...
                        Else
                            '...only link the data range.
                            Workbooks(strThisWkb).Sheets(strConsTab).Range("A" & lngPasteRow & ":Z" & lngPasteRow + rowCountSource - 1).Value = _
                            Workbooks(objFile.Name).Sheets(4).Range("A2:Z" & rowCountSource).Value 'Link workbook only has 1 tab.
                        End If
            'Else, set the 'lngPasteRow' variable and open the workbook.
            Else
            LastrowDes = Workbooks(strThisWkb).Sheets(strConsTab).Cells(Rows.Count, "A").End(xlUp).Row
                lngPasteRow = _
                    Workbooks(strThisWkb).Sheets(strConsTab).Cells(Rows.Count, "A").End(xlUp).Row + 1
                    Workbooks.Open Filename:=strDir & "\" & objFile.Name
                                rowCountSource = Workbooks(objFile.Name).Sheets(4).Cells(Rows.Count, "A").End(xlUp).Row

                    'If the 'lngPasteRow' variable value is 2, then...
                    If lngPasteRow = 2 Then
                        '...link the entire range (i.e. headings + data) as this is the first file being imported.
                        Workbooks(strThisWkb).Sheets(strConsTab).Range("A1:Z" & rowCountSource).Value = _
                        Workbooks(objFile.Name).Sheets(4).Range("A1:Z" & rowCountSource).Value 'Link workbook only has 1 tab.
                        'Else...
                    Else
                        '...only link the data range.
                        Workbooks(strThisWkb).Sheets(strConsTab).Range("A" & lngPasteRow & ":Z" & lngPasteRow + rowCountSource - 1).Value = _
                        Workbooks(objFile.Name).Sheets(4).Range("A2:Z" & rowCountSource).Value 'Link workbook only has 1 tab.
                    End If
                    'Close the just opened file without saving any changes to it.
                    Workbooks(objFile.Name).Close False
            End If
        End If
       
    'Release memory
    Set objFSO = Nothing
    Set objFolder = Nothing
    Set objFile = Nothing
       
    Next objFile
   
    Application.ScreenUpdating = True
   
    MsgBox "Data from each workbook in the """ & strDir & """ directory has now been imported to the """ & strConsTab & """ tab.", vbInformation, "Import Data Editor"
   
End Sub

No comments:

Post a Comment