VBA - Select file, copy sheets, run code in all sheets

[jocker_boy]

Hello,

I have already a code that is working for me.
It's not the perfect code, but it is what i could do
Now i want to upgrade this code so that i can create a template file.

Sub PlanoPagamentos()

'Add sheet auxiliar
    Sheets.add(Before:=Sheets(1)).Name = "AUX"

'Project Dates
    Dim strDate As String
    Dim LastMonth As Long
    Dim sht As Worksheet
    Dim MyNamedRng As Range
 
'Insert First Date
    strDate = InputBox("Insert start of the project (mm/yy)", "Enter Date", Format(Date, "mm/yy"))
 
    strDate = Format(CDate("01/" & strDate), "mm/dd/yy")
 
'Inserir número de meses do projeto
    LastMonth = InputBox(Prompt:="How many months have the project?")

'Criação da tabela
    Range("A1") = "N.º"
    Range("B1") = "Month"
   
    Range("A2") = 1
    Range("B2") = strDate

    Range("A3:A" & LastMonth + 1).Formula = "=$A2 + 1"
    Range("B3:B" & LastMonth + 1).Formula = "=edate(B2,1)"
    Range("B2:B" & LastMonth + 1).NumberFormat = "mmm-yy"
   
    Set sht = Sheets("AUX")
    Set MyNamedRng = sht.Range("B2:B" & LastMonth + 1)
    ActiveWorkbook.Names.add Name:="Datas", RefersTo:=MyNamedRng
   
'Activate Sheet
    Sheets(3).Activate

'Add Auxiliar Columns
    Range("A:B").EntireColumn.Insert
        Range("A5") = "AUX"
        Range("B5") = "LEN"
    Range("F:G").EntireColumn.Insert
        Range("F5") = "S/E"
        Range("G5") = "PP"

'Get Last Row and Last Column
    Dim lr As Long
    Dim lc As Long
 
'   Find last row in column C with data
    lr = Cells(Rows.Count, "C").End(xlUp).row
   
'   Find last column in row 5 with data
    lc = Cells(1, columns.Count).End(xlToLeft).Column

'Populate First Auxiliar Columns
    Dim A As Long
    Dim B As Long
   
    Range("A6:A" & lr).Formula = "=IF(LEN($C6)<9,1,IF(AND(LEN($C6)=11,ISBLANK($E6)),2,IF(ISBLANK($E6),3,"""")))"
    Range("B6:B" & lr).Formula = "=LEN($C6)"

    A = Cells(Rows.Count, 1).End(xlUp).row
    B = Cells(Rows.Count, 2).End(xlUp).row
       
    If A = B Then
   
    Cells(lr + 1, 1).Value = 1
   
    Else
   
    Cells(lr, 1).Value = 1
       
    End If
   
'Populate columns Total
Dim r As Long, r2 As Long, last_row As Long
Dim next_row As Long, current_len As Long, test_len As Long
Dim Rng As String

With ActiveSheet

last_row = .Cells(Rows.Count, 1).End(xlUp).row

Range("K6:K" & last_row - 1).Formula = "=$I6*$J6"

For r = 6 To last_row
    next_row = r + 1

    If .Range("B" & next_row) > .Range("B" & r) Then
       current_len = .Range("B" & r)
     
       'create range
       For r2 = r + 1 To last_row
            test_len = .Range("B" & r2)
            If current_len >= test_len Then
                Rng = "K" & r + 1 & ":" & "K" & r2 - 1
                Exit For
            End If
        Next
   
        .Range("K" & r).Formula = "=SUBTOTAL(9," & Rng & ")"
    End If
   
Next

End With


'Pupulate Total
    Range("D4").Formula = "=$K$6"
   
   
'Create Headers
    Cells(5, lc + 1).Value = 1
    Cells(5, lc + 2).Value = strDate
    Cells(5, lc + 2).NumberFormat = "mmm/yy"
 
Call month


'Format month cells
    Range(Cells(5, lc + 2), Cells(lr, lc + 1)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlDash
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlDash
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With


'expand months

    Dim LastCol As Long
    Dim copyCol As Range
    Dim DestRange As Range
    Dim lastRow As Long

    With ThisWorkbook.Sheets("Lote 2 (F2.0)")

        lastRow = .Cells(.Rows.Count, "C").End(xlUp).row
        LastCol = .Cells(5, .columns.Count).End(xlToLeft).Column

        Set copyCol = .Range(.Cells(5, LastCol - 1), .Cells(lastRow, LastCol))

        Set DestRange = .Range(.Cells(5, LastCol - 1).Resize(, 2), .Cells(lastRow, LastCol + LastMonth * 2))

        copyCol.AutoFill Destination:=DestRange, Type:=xlFillDefault

    End With
   
   
    Range(Cells(5, LastCol + 1), Cells(5, LastCol + 1)).FormulaR1C1 = "=R[0]C[-2]+1"
    Range(Cells(5, LastCol + 2), Cells(5, LastCol + 2)).FormulaR1C1 = "=edate(R[0]C[-2],1)"
    Range(Cells(5, LastCol + 2), Cells(5, LastCol + 2)).NumberFormat = "mmm/yy"

    'Dim LastCol As Long
    'Dim copyCol As Range
    'Dim DestRange As Range


    With ThisWorkbook.Sheets("Lote 2 (F2.0)")
   
        'lastRow = .Cells(.Rows.Count, "C").End(xlUp).row
        'LastCol = .Cells(5, .columns.Count).End(xlToLeft).Column

        Set copyCol = .Range(.Cells(5, LastCol + 1), .Cells(5, LastCol + 2))

        Set DestRange = .Range(.Cells(5, LastCol + 1).Resize(, 2), .Cells(5, LastCol + 2 + LastMonth * 2 - 2))

        copyCol.AutoFill Destination:=DestRange, Type:=xlFillDefault

    End With

'Format headers
    Dim lc2 As Long
 
'Group Columns
    ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=8

'   Find last column in row 5 with data
    lc2 = Cells(5, columns.Count).End(xlToLeft).Column

'Ungroup Columns
    ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1

    Range(Cells(5, lc2), Cells(5, "A")).Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection.Font
        .Name = "Arial"
        .FontStyle = "Negrito"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With

Call Color

End Sub

Sub month()

    Dim lr As Long
    Dim lc As Long
 

'   Find last row in column C with data
    lr = Cells(Rows.Count, "C").End(xlUp).row
   
'   Find last column in row 5 with data
    lc = Cells(5, columns.Count).End(xlToLeft).Column

    Cells(6, lc).Select
    Range(Cells(6, lc), Cells(lr, lc)).FormulaR1C1 = "=R[0]C[-1]*" & Application.ConvertFormula("$J6", xlA1, xlR1C1)

'Populate Month Column
Dim r As Long, r2 As Long, last_row As Long
Dim next_row As Long, current_len As Long, test_len As Long
Dim Rng As String

With ActiveSheet

last_row = .Cells(Rows.Count, 1).End(xlUp).row

For r = 6 To last_row
    next_row = r + 1

    If .Range("B" & next_row) > .Range("B" & r) Then
       current_len = .Range("B" & r)
     
       'create range
       For r2 = r + 1 To last_row
            test_len = .Range("B" & r2)
            If current_len >= test_len Then
                'Rng = "EE" & r + 1 & ":" & "EE" & r2 - 1
                Rng = Range(Cells(r + 1, lc), Cells(r2 - 1, lc)).Address(ColumnAbsolute:=False)
                Exit For
            End If
        Next
   
        .Cells(r, lc).Formula = "=SUBTOTAL(9," & Rng & ")"
    End If
   
Next

End With

End Sub

Sub Color()

    Dim lr As Long
    Dim lc As Long
    Dim MyRange As Range
   
   
'   Find last row in column C with data
    lr = Cells(Rows.Count, "C").End(xlUp).row
   
'   Find last column in row 5 with data
    lc = Cells(5, columns.Count).End(xlToLeft).Column
   
    Set MyRange = Range(Cells(6, "A"), Cells(lr, lc))
   
    'Delete Existing Conditional Formatting from Range
    MyRange.FormatConditions.Delete
   
    'Apply Conditional Formatting
    MyRange.FormatConditions.add Type:=xlExpression, Formula1:="=$A6=1"
    MyRange.FormatConditions(1).Interior.Color = RGB(104, 226, 209)
    MyRange.FormatConditions(1).Font.Bold = True
    MyRange.FormatConditions.add Type:=xlExpression, Formula1:="=$A6=2"
    MyRange.FormatConditions(2).Interior.Color = RGB(197, 243, 236)
    MyRange.FormatConditions(2).Font.Bold = True
    MyRange.FormatConditions.add Type:=xlExpression, Formula1:="=$A6=3"
    MyRange.FormatConditions(3).Interior.Color = RGB(242, 242, 242)
    MyRange.FormatConditions(3).Font.Bold = True
   
End Sub

My goal is:

• In the beginning i want to have the possibility to have a window to select one file;
• After select the file, i want to copy all sheets of that file to the template file;
• After i need i question to answer how many sheet's i want to run the code;
• After i need to run the code in the number of sheets answered before, counting from the last to the begin.
  • For example if the file that i copy has 4 sheets and i answered 3 sheets, the code will run in the last 3 sheets.
  • For example if the file that i copy has 5 sheets and i answered 2 sheets, the code will run in the last 2 sheets.
• In my code above, i have the first part where i create one auxiliar sheet and then, my code started this way: "Sheets(3).Activate"
  • So it only runs in my third sheet. I need to replace this to run in sheets that i answered before.

Thanks in advance.