Append Some macro with one input box

[Leviathan87]

Hi everyone! I want to as something about VBA macro
I have some macro to append different workbook into one master file. Every time i must running one by one with input date.
Is there a variant to start all macro with one input box.
All macro is the same .... like this... and im trying to run all with one input box date!

Sub Collected()
Dim Source As String
Dim WB5 As Object 
Dim WB5name As String 
Dim LR5 As Long 
Dim LR6 As Long
Dim WBname As String 
Dim MyBox As Variant

Dim LR As Long, I As Long, IRow As Long, IRow2 As Long

WBname = ThisWorkbook.name
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
MyBox = InputBox("Set Date if format YYYYmmdd", Date)

Source = "" & "_Collected_" & MyBox & "_ready" & ".xlsx"


Set WB5 = Workbooks.Open(Source)
WB5name = "Collected_" & MyBox & "_" & ".xlsx"

LR5 = Workbooks(WB5name).Worksheets(1).Cells(Rows.Count, 2).End(xlUp).Row


If 2 > LR5 Then Exit Sub
IRow = Workbooks(WBname).Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Row + 1 '// Start row to paste
    
        For I = 2 To LR5
    
        If Workbooks(WB5name).Worksheets(1).Cells(I, "R").Interior.Color <> 16777215 Then
        Workbooks(WB5name).Worksheets(1).Cells(I, "R").Copy Workbooks(WBname).Worksheets("Sheet2").Cells(IRow, "A")
        IRow = IRow + 1
        
        End If
      
    Next I

 If 2 > LR5 Then Exit Sub
    
    
    IRow = Workbooks(WBname).Worksheets(2).Cells(Rows.Count, 2).End(xlUp).Row + 1 '// Start row to paste
    
    For I = 2 To LR5
    
        If Workbooks(WB5name).Worksheets(1).Cells(I, "B").Interior.Color <> 16777215 Then
        Workbooks(WB5name).Worksheets(1).Cells(I, "B").Copy Workbooks(WBname).Worksheets("Sheet2").Cells(IRow, "B")
        IRow = IRow + 1
        
        End If
      
    Next I
If 2 > LR5 Then Exit Sub
    
    
    IRow = Workbooks(WBname).Worksheets(2).Cells(Rows.Count, 3).End(xlUp).Row + 1 '// Start row to paste
    
    For I = 2 To LR5
    
        If Workbooks(WB5name).Worksheets(1).Cells(I, "O").Interior.Color <> 16777215 Then
        Workbooks(WB5name).Worksheets(1).Cells(I, "O").Copy Workbooks(WBname).Worksheets("Sheet2").Cells(IRow, "C")
        IRow = IRow + 1
        
        End If
      
    Next I
    
   If 2 > LR5 Then Exit Sub
    
    
    IRow = Workbooks(WBname).Worksheets(2).Cells(Rows.Count, 4).End(xlUp).Row + 1 '// Start row to paste
    
    For I = 2 To LR5
    
        If Workbooks(WB5name).Worksheets(1).Cells(I, "S").Interior.Color <> 16777215 Then
        Workbooks(WB5name).Worksheets(1).Cells(I, "S").Copy Workbooks(WBname).Worksheets("Sheet2").Cells(IRow, "D")
        IRow = IRow + 1
        
        End If
      
    Next I
    
    If 2 > LR5 Then Exit Sub
    
    
    IRow = Workbooks(WBname).Worksheets(2).Cells(Rows.Count, 5).End(xlUp).Row + 1 '// Start row to paste
    
    For I = 2 To LR5
    
        If Workbooks(WB5name).Worksheets(1).Cells(I, "W").Interior.Color <> 16777215 Then
        Workbooks(WB5name).Worksheets(1).Cells(I, "W").Copy Workbooks(WBname).Worksheets("Sheet2").Cells(IRow, "E")
        IRow = IRow + 1
        
        End If
      
    Next I
    
  If 2 > LR5 Then Exit Sub
    
    
    IRow = Workbooks(WBname).Worksheets(2).Cells(Rows.Count, 6).End(xlUp).Row + 1 '// Start row to paste
    
    For I = 2 To LR5
    
        If Workbooks(WB5name).Worksheets(1).Cells(I, "O").Interior.Color <> 16777215 Then
      Workbooks(WBname).Worksheets("Sheet2").Cells(IRow, "F").Value = " "
        IRow = IRow + 1
        
        End If
      
    Next I
     
 
 LR6 = Workbooks(WBname).Worksheets(5).Cells(Rows.Count, 2).End(xlUp).Row
  If 2 > LR5 Then Exit Sub
  For I = 1 To LR5
  
          If Workbooks(WB5name).Worksheets(1).Cells(I, "T").Value = "x" Then
          IRow2 = Workbooks(WBname).Worksheets(5).Cells(Rows.Count, 2).End(xlUp).Row
      Workbooks(WB5name).Worksheets(1).Rows(I).Copy Workbooks(WBname).Worksheets("Sheet5").Cells(IRow2 + 1, "A")
       
         End If
      
    Next I
 
Workbooks(WB5name).Close

End Sub