Microsoft Office Forums - View Single Post

ryguy551 · 05-22-2014, 12:31 PM

Hello i am trying to make a macro that will allow me to merge specific spreadsheets with specific names. As you will see in my code one of the sheets names is planting a. when i run the macro with just planting a it works perfectly but when i try to add another if statement to get multiple sheets to merge i get errors here is the code please help with what i can add.

Code:

Function LastRow(sh As Worksheet) 
    On Error Resume Next 
    LastRow = sh.Cells.Find(What:="*", _ 
    After:=sh.Range("A1"), _ 
    Lookat:=xlPart, _ 
    LookIn:=xlFormulas, _ 
    SearchOrder:=xlByRows, _ 
    SearchDirection:=xlPrevious, _ 
    MatchCase:=False).Row 
    On Error Goto 0 
End Function 
 
Function LastCol(sh As Worksheet) 
    On Error Resume Next 
    LastCol = sh.Cells.Find(What:="*", _ 
    After:=sh.Range("A1"), _ 
    Lookat:=xlPart, _ 
    LookIn:=xlFormulas, _ 
    SearchOrder:=xlByColumns, _ 
    SearchDirection:=xlPrevious, _ 
    MatchCase:=False).Column 
    On Error Goto 0 
End Function

Sub CopyRangeFromMultiWorksheets() 
    Dim sh As Worksheet 
    Dim DestSh As Worksheet 
    Dim Last As Long 
    Dim CopyRng As Range 
     
    With Application 
        .ScreenUpdating = False 
        .EnableEvents = False 
    End With 
     
     ' Delete the summary sheet if it exists.
    Application.DisplayAlerts = False 
    On Error Resume Next 
    ActiveWorkbook.Worksheets("RDBMergeSheet").Delete 
    On Error Goto 0 
    Application.DisplayAlerts = True 
     
     ' Add a new summary worksheet.
    Set DestSh = ActiveWorkbook.Worksheets.Add 
    DestSh.Name = "RDBMergeSheet" 
     
     ' Loop through all worksheets and copy the data to the
     ' summary worksheet.
    For Each sh In ActiveWorkbook.Worksheets 
        If LCase(Left(sh.Name, 10)) = "planting a" Then 
             
             ' Find the last row with data on the summary worksheet.
            Last = LastRow(DestSh) 
             
             ' Specify the range to place the data.
            Set CopyRng = sh.Rows("1:500") 
             
             ' Test to see whether there are enough rows in the summary
             ' worksheet to copy all the data.
            If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then 
                MsgBox "There are not enough rows in the " & _ 
                "summary worksheet to place the data." 
                Goto ExitTheSub 
            End If 
             ' This statement copies values and formats from each
             ' worksheet.
            CopyRng.Copy 
            With DestSh.Cells(Last + 1, "A") 
                .PasteSpecial xlPasteValues 
                .PasteSpecial xlPasteFormats 
                Application.CutCopyMode = False 
            End With 
             
             ' Optional: This statement will copy the sheet
             ' name in the H column.             
        End If          
    Next 
     
ExitTheSub: 
     
    Application.Goto DestSh.Cells(1) 
     
     ' AutoFit the column width in the summary sheet.
    DestSh.Columns.AutoFit 
     
    With Application 
        .ScreenUpdating = True 
        .EnableEvents = True 
    End With 
End Sub

This code works fine but i want to add another if statement to detect other names of sheets thanks!