Drop Down MenusCSS Drop Down MenuPure CSS Dropdown Menu

Thursday 31 March 2016

How to consolidate two or more Workbook into a Workbook In different 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 ConsolidateInDifferntSheet()

    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" 'Change to suit
    strThisWkb = ThisWorkbook.Name
    'strConsTab = "Sheet1" 'Change to suit
 
       ' Sheets.Add.Name = MyNewSheet.Value

    'MyNames.Worksheet.Select
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFSO.GetFolder(strDir)
   
    Application.ScreenUpdating = False
     
 
   
    For Each objFile In objFolder.Files
    Workbooks(strThisWkb).Sheets.Add.Name = Split(objFile.Name, ".")(0)
    strConsTab = Split(objFile.Name, ".")(0)
     '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
        '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
         
            rowCountSource = Workbooks(objFile.Name).Sheets(4).Cells(Rows.Count, "A").End(xlUp).Row
             
                            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
         
                    Workbooks.Open Filename:=strDir & "\" & objFile.Name
                                rowCountSource = Workbooks(objFile.Name).Sheets(4).Cells(Rows.Count, "A").End(xlUp).Row

                        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.
                 
                    '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