Loop code for certain worksheets in workbook

Hello, could some one please be so kind as to help me loop my VBA code (Excel 2003) so that it performs the same procedure for worksheets: E-1, E-2, E-3, E-4. I am sorry about the large file sizes of the attached workbooks. I made them as small as possible. The original spreadsheet (which is not mine) is 35Mb. I was asked to create this macro on a poorly designed spreadsheet

The code shown below does work OK (unfortunately, I am not a VBA programmer) so I guess the code is poorly written.

If any one is able to please help, then they will need to have both workbooks open at the same time.

At the moment when you run the code, it will only do worksheet named: E-1.

In order to keep the file size down, I removed 15 other worksheets. I need the loop to only loop through specific worksheets: E-1, E-2, E-3 & E-7. There are other worksheets in the original spreadsheet that have worksheets named: E-16 & E-20 for example that I do not wish to include in the loop.

Once the data is copied and pasted into Workbook named: HR Locations and into worksheet named: 1 Mth and Range: A3 then any other data from worksheets E-2, E-3 & E-7 needs to be appended at the bottom of any data that was copied from worksheet E-1 in worksheet named: 1 Mth.

If you require further clarification, please let me know.

Kind regards,

Chris

Sub Report4321_1MTH()
    '
    '  4-3-2-1 Report 1 MTH
    '
    Dim DateIni As Date
    Dim DateEnd As Date
    Dim DateIniAF As Long
    Dim DateEndAF As Long
    Dim rng As Range
    Dim rng2 As Range
    Dim D1 As Date
    Dim S1 As String
    Dim Sin1 As String
    Dim Sep1 As String
    Dim D2 As Date
    Dim S2 As String
    Dim Sin2 As String
    Dim Sep2 As String
    Dim lr As Long
    Dim wb As Workbook
    Dim AlreadyOpen As Boolean
    Dim Mth1 As Worksheet
    Dim Mth2 As Worksheet
    Dim Mth3 As Worksheet
    Dim Mth4 As Worksheet
    Dim WorksheetName1 As String
    
    Application.ScreenUpdating = False
    
    Windows("HR Locations.xls").Activate
    Worksheets("E-1").Select
    
    ' Asks user to open the 4-3-2-1 Report and if it is not open then for the user to cancel this operation.
    '
    lr = MsgBox("Please open the 4-3-2-1 Report.xls file from within the Records Management System in a New Version. If it is not already open, please click on the <Cancel> button.", _
      vbOKCancel, "")
    If lr = vbCancel Then Exit Sub
    
    ' Checks to determine if the 4-3-2-1 Report is open.  If it is not open, then the user is atomatically exited out of this subroutine.
    '
    AlreadyOpen = False
    For Each wb In Workbooks
        If wb.Name = "4-3-2-1 Report.xls" Then
            AlreadyOpen = True
            Exit For
        End If
    Next wb
    If AlreadyOpen = False Then MsgBox "The 4-3-2-1 Report.xls file is not currently open," & vbCrLf & "please open the file and try again."
    If AlreadyOpen = False Then Exit Sub
    
    ' Deletes a worksheet in the 4-3-2-1 Report so that a new one can be inserted with new populated data.
    '
    If MsgBox("Clicking <Yes> will delete the 1 Mth worksheet from the 4-3-2-1 Report.  This is required to enable the new dataset to be populated into the 4-3-2-1 Report.  Do you wish to continue? ", _
    vbYesNo) = vbNo Then Exit Sub
    
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Windows("4-3-2-1 Report.xls").Activate
    Sheets("1 Mth").Select
    ActiveWindow.SelectedSheets.Delete
    Windows("HR Locations.xls").Activate
    Range("A101").Select
    Application.EnableEvents = True
    Application.DisplayAlerts = True
       
    ' Clears the data in the worksheet so that the new data can be populted in its place (does not include the header).
    '
    If MsgBox("Clicking <Yes> will clear all data in the 1 Mth worksheet from the HR Locations spreadsheet.  This is required to enable the new dataset to be populated into the HR Locations spreadsheet.  Do you wish to continue? ", _
    vbYesNo) = vbNo Then Exit Sub
    
    Application.DisplayAlerts = False
    
    Set Mth1 = ThisWorkbook.Sheets("1 Mth")
    Mth1.Range("A3:A" & Rows.Count).EntireRow.Clear
    
    Application.DisplayAlerts = True

    On Error Resume Next
    
    'Asks user for the First date and validates it.
    '
    Sep1 = Application.International(xlDateSeparator)
    Sin1 = Application.InputBox("Enter Today's date in dd/mm/yy format")
    
    S1 = Trim(Sin1)
    If Right(S1, 1) = Sep1 Then S1 = Left(S1, Len(S1) - 1)
    
    On Error GoTo Whoops1
    
    If Len(S1) = 2 Then
        D1 = DateSerial(S1, 1, 1)
    ElseIf InStr(S1, Sep1) Then
        D1 = CDate(S1)
    Else
        S1 = Format(S1, "!&&" & Sep1 & "&&" & "/" & "&&&&")
    If Right(S1, 1) = Sep1 Then S1 = Left(S1, Len(S1) - 1)
        D1 = CDate(S1)
    End If
    
    'MsgBox "Date entered: " & D1
    
    DateIni = Sin1
    DateIni = DateSerial(Year(DateIni), Month(DateIni), Day(DateIni))
    DateIniAF = DateIni
    
    ' Asks the user for the Second Date and validates it.
    '
    Sep2 = Application.International(xlDateSeparator)
    Sin2 = Application.InputBox("Enter Today's date + 30 days in dd/mm/yy format")
    
    S2 = Trim(Sin2)
    If Right(S2, 1) = Sep2 Then S2 = Left(S2, Len(S2) - 1)
    
    On Error GoTo Whoops2
    
    If Len(S2) = 2 Then
        D2 = DateSerial(S2, 1, 1)
    ElseIf InStr(S2, Sep2) Then
        D2 = CDate(S2)
    Else
        S2 = Format(S2, "!&&" & Sep2 & "&&" & "/" & "&&&&")
    If Right(S2, 1) = Sep2 Then S2 = Left(S2, Len(S2) - 1)
        D2 = CDate(S2)
    End If
    
    'MsgBox "Date entered: " & D2
   
    DateEnd = Sin2
    DateEnd = DateSerial(Year(DateEnd), Month(DateEnd), Day(DateEnd))
    DateEndAF = DateEnd
    
   ' Applies an AutoFilter for column ("AN") for the dates and column ("AQ") for Replacement Incumbent "Vacant" positions.
   '
    Worksheets("E-1").Select
         
            WorksheetName1 = Worksheets("E-1").Name
            
    ' Checks worksheet to determine if the AutoFilter is off.  If so, the user is advised and exited out of the subroutine.
    '
            If ActiveSheet.AutoFilterMode = False Then
    
                MsgBox "The Worksheet " & WorksheetName1 & " does not have the AutoFilter on, " & vbCrLf & "please turn the AutoFilter on and try again."
            
            End If
    
            If ActiveSheet.AutoFilterMode = False Then
            
                Windows("4-3-2-1 Report.xls").Activate
                Application.EnableEvents = False
                Worksheets.Add().Name = "1 Mth"
                Application.EnableEvents = True
                Windows("HR Locations.xls").Activate
                
            End If
            
            If ActiveSheet.AutoFilterMode = False Then Exit Sub
                        
    ' Checks worksheet to determine if the AutoFilter is on and if there is any filters currently applied.  If so, the user is advised and exited out of the subroutine.
    '
                If ActiveSheet.AutoFilterMode = True And ActiveSheet.FilterMode = True Then
            
                    MsgBox "The Worksheet " & WorksheetName1 & " has a filter or filters swithed on, " & vbCrLf & "please turn off the all filter(s) and try again."
            
                End If
                
                If ActiveSheet.AutoFilterMode = True And ActiveSheet.FilterMode = True Then
                
                    Windows("4-3-2-1 Report.xls").Activate
                    Application.EnableEvents = False
                    Worksheets.Add().Name = "1 Mth"
                    Application.EnableEvents = True
                    Windows("HR Locations.xls").Activate
                    
                End If
               
                If ActiveSheet.AutoFilterMode = True And ActiveSheet.FilterMode = True Then Exit Sub
                
                Selection.AutoFilter Field:=40, Criteria1:=">=" & DateIniAF, Operator:= _
        xlAnd, Criteria2:="<=" & DateEndAF
    Selection.AutoFilter Field:=43, Criteria1:="=VACANT", Operator:=xlAnd
  
                With ActiveSheet.AutoFilter.Range
                    On Error Resume Next
                    Set rng2 = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
                    .SpecialCells(xlCellTypeVisible)
                    On Error GoTo 0
                End With
                If Not rng2 Is Nothing Then
                     Set rng = ActiveSheet.AutoFilter.Range
                     rng.Offset(1, 0).Resize(rng.Rows.Count - 1).Copy _
                     Destination:=Worksheets("1 Mth").Range("A3")
                End If
                ActiveSheet.ShowAllData
    
    ' The worksheet containing the new filtered data is then copied into the 4-3-2-1 Report.
    '
            Windows("HR Locations.xls").Activate
   
            Sheets("1 Mth").Select
    
            Sheets("1 Mth").Copy After:=Workbooks("4-3-2-1 Report.xls").Sheets(1)
            Application.EnableEvents = False
            Windows("4-3-2-1 Report.xls").Activate
            Worksheets("Sheet1").Select
            Application.EnableEvents = True
   
   Application.ScreenUpdating = True
   
   Exit Sub
   
Whoops1:
    MsgBox "Invalid date: " & Sin1
    Exit Sub
    
Whoops2:
    MsgBox "Invalid date: " & Sin2
    Exit Sub
    
    Application.ScreenUpdating = True
    
End Sub