Posts by zxox

Sub g_CombineMultWB_AllXLSFiles()      ' This Will combine all EMALL XLS files located in the
     '   S:\DMSMS\POMS\Master POMS NIIN Data\Master EMALL Data Files\EMALL Excel Folder
     ' into a single worksheet in a newly created (or previously existing) workbook
     ' LOCATION OF FILES (ACTUAL):
     '      S:\DMSMS\POMS\Master POMS NIIN Data\Master EMALL Data Files\EMALL Excel Folder
    
    Dim i As Integer 
    Dim wbResults As Workbook 
    Dim wbCodeBook As Workbook 
    Dim f As Worksheet, t As Worksheet, nNew As Long, nOld As Long 
    Application.ScreenUpdating = False 
    Application.DisplayAlerts = False 
    Application.EnableEvents = False 
    
    On Error Resume Next 
    
     '   Change path To suit
    Const MYFOLDER = "S:\DMSMS\POMS\Master POMS NIIN Data\Master EMALL Data Files\EMALL Excel Folder\" 
     '   Const MYFOLDER = "G:\CDMO\Combine Multiple WB (Emall Data)\Test Data 2\"
     '   Reset to "Combined EMALL Data.xls" workbook and make sure it is open
    Set wbCodeBook = Workbooks.Open(MYFOLDER & "Combined EMALL Data.xls") 
    Set t = wbCodeBook.Sheets(1) 'The sheet to hold all of the data
    t.Rows("2:" & Rows.Count).Clear 'CLEAR ANY OLD DATA
    nOld = 2 'Row to copy data to (starting AFTER the header row)
    With Application.FileSearch 
        .NewSearch 
        .LookIn = MYFOLDER 
        .FileType = msoFileTypeExcelWorkbooks 
        If .Execute > 0 Then 'See if workbooks exist in target folder
            For i = 1 To .FoundFiles.Count 'Loop through all workbooks in target folder
                If .FoundFiles(i) <> wbCodeBook.FullName Then 
                    Set wbResults = Workbooks.Open(.FoundFiles(i)) 
                    Set f = wbResults.Sheets(1) 'Worksheet to process
                    nNew = f.Cells(Rows.Count, 1).End(xlUp).Row 'Last row with entry in column 1
                    If nNew > 1 Then 'This means we have some data
                        If nOld + nNew - 2 <= Rows.Count Then 'This means there's room to copy
                            f.Rows("2:" & nNew).Copy t.Cells(nOld, 1) 
                            nOld = nOld + nNew - 1 
                        Else 
                            MsgBox "There is not enough room to copy the data from " _ 
                            & .FoundFiles(i), vbCritical, "Out of Room" 
                            Exit For 
                        End If 
                    End If 
                End If 
                wbResults.Close False 'Close workbook without saving
            Next i 
        End If 
    End With 
     ' Pretty up the worksheet
    Columns("A:D").Select 
    Range("A6873").Activate 
    Selection.ColumnWidth = 12 
    Range("A1").Select 
    On Error Goto 0 
    Application.ScreenUpdating = True 
    Application.DisplayAlerts = True 
    Application.EnableEvents = True 
    Application.CutCopyMode = False ' Clear last copy
End Sub

Sub CopySheetsToSummary()
     
    Dim ws As Worksheet
    Dim wsDest As Worksheet
    Dim RangeToCopy As Range
    Dim RangeToPaste As Range
     
    Set wsDest = Worksheets("Summary")
     
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> wsDest.Name Then
            Set RangeToCopy = ws.Range("a11", ws.Range("a65536").End(xlUp)).EntireRow
            Set RangeToPaste = wsDest.Range("a65536").End(xlUp).Offset(2, 0)
            If RangeToPaste.Address = "$A$3" Then Set RangeToPaste = Range("a11")
            RangeToCopy.Copy RangeToPaste
        End If
    Next
End Sub