Подскажите как можно упростить этот код - VB

Const isDebugMode = True
Const newNameSh = "CRMds"
Const ourBook = "___CRnnnn_QA Estimation Evaluation_JIRA_YYYYMMDDVersion1.0.xlsm"
Const ourList = "Estimation"
Const newNameBudget = "CRBudget"
 
Dim tasks
 
Sub CR_Mds_Estimation_upload()
    CreateNewExcelmy (newNameSh)
    
    For iCurrCol = 1 To 10
    WS.Columns(iCurrCol).ColumnWidth = 12
    Next
    
    'шапка
    WS.Cells(1, 1).Value = "CRCode"
    WS.Cells(1, 2).Value = "* Resource Role"
    WS.Cells(1, 3).Value = "* Skill"
    WS.Cells(1, 4).Value = "Resource"
    WS.Cells(1, 5).Value = "* M/d estimation"
    WS.Cells(1, 6).Value = "Task"
    WS.Cells(1, 7).Value = "Phase"
    WS.Cells(1, 8).Value = "Department"
    WS.Cells(1, 9).Value = "Year"
    WS.Cells(1, 10).Value = "Comment"
    
    'рамка и цвет ячеек
    With WS.Range("A1:J1")
        .Interior.Color = RGB(244, 236, 197)
        .Borders.LineStyle = xlContinuous
        .Borders.Color = RGB(204, 192, 133)
    End With
    
    'получение номера последней пустой строки
    Dim numStr As Long
    numStr = WS.Cells(Rows.Count, 1).End(xlUp).Row + 1
    
    'номер CR
    'Workbooks(ourBook).Activate
    'WS.Range("A2:A6").Value = Worksheets(ourList).Range("C2").Value
    Dim startpstr As Integer
    Dim endpstr As Integer
    Dim lenpstr As Integer
    startpstr = InStr(Range("B2").Value, "[") + 3
    endpstr = InStr(Range("B2").Value, "]")
    lenpstr = endpstr - startpstr
    WS.Range("A2:A6").Value = Mid(Range("B2").Value, startpstr, lenpstr)
    
    'объединение ячеек
    'WS.Range("A2:A6").Merge
 
    'Task
    tasks = Array(9, 12, 17, 22, 26) 'какие ячейки надо копировать
    Dim i As Integer
    Dim numlastTaskStr As Long
    numlastTaskStr = Worksheets("Task").Cells(Rows.Count, 1).End(xlUp).Row
    
    For i = 0 To 4
        For j = 1 To numlastTaskStr
            If Range("A" + CStr(tasks(i))).Value = Worksheets("Task").Cells(j, 3) Then
                WS.Range("F" + CStr(i + 2)).Value = Worksheets("Task").Cells(j, 2)
                WS.Range("B" + CStr(i + 2)).Value = Worksheets("Task").Cells(j, 5)
            End If
        Next j
    Next i
    
    WS.Range("B2:B6").WrapText = True
    WS.Range("F2:F6").WrapText = True 'перенос по словам
    WS.Range("J2:J6").WrapText = True
    
    'skill
    Dim numlastSkillStr As Long
    numlastSkillStr = Worksheets("Skill").Cells(Rows.Count, 1).End(xlUp).Row
    
    For i = 1 To numlastSkillStr
        If Worksheets("Skill").Cells(i, 2) = "Quality Assurance" Then
        WS.Range("C2:C6").Value = Worksheets("Skill").Cells(i, 2).Value
        End If
    Next i
    
    'M/d
      
    For i = 0 To 4
    WS.Range("E" + CStr(i + 2)).Value = Range("C" + CStr(tasks(i))).Value
    Next i

    'phase
    WS.Range("G2:G6").Value = Worksheets("Phase").Range("A4").Value
    
    'department
    WS.Range("H2:H6").Value = Worksheets("Department").Range("A8").Value
    
    'год
    WS.Range("I2:I6").Value = Year(Now)
    
    'WS.Range("I2:I6").VerticalAlignment = xlTop
   
   'comment
    
    For i = 0 To 4
    WS.Range("J" + CStr(i + 2)).Value = Range("A" + CStr(tasks(i))).Value
    Next i
    
    WS.Range("A1:K100").Font.Size = 8
    
    'рамка и цвет ячеек
    With WS.Range("A2:J6")
        .Interior.Color = RGB(255, 255, 255)
        .Borders.LineStyle = xlContinuous
        .Borders.Color = RGB(204, 192, 133)
    End With
    
   'Удалить строки с нулевой суммой
    For i = 0 To 4
    If WS.Range("E" + CStr(i + 2)).Value = "0" Then
        Set objRange = WS.Range("E" + CStr(i + 2)).EntireRow
        objRange.Delete
        i = i - 1
    End If
    Next i
 
    SaveNewFileExcel ("_PPM_upload_MDs")
    CloseFile
    
End Sub

Sub CreateNewExcelmy(nName As String)
 
'Создаем новую книгу
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Add
Set WS = xlBook.Worksheets(1)
WS.Name = nName
 
'Необходимо для отладки
If isDebugMode = True Then
    xlApp.Visible = True
End If
 
End Sub
 
Sub SaveNewFileExcel(fileNm As String)
'Функция сохраняет полученный файл в ту же директорию где и оригинал
 
Dim pathName As String

'Получаем имя файла без расширения
curFileName = Split(ActiveWorkbook.Name, ".")
 
'Формируем полное имя файла
 
pathName = ActiveWorkbook.Path + "\" + curFileName(0)
pathName = Replace(pathName, " Estimation Evaluation", fileNm)

'Сохраняем сформированный файл
Application.DisplayAlerts = False
xlBook.SaveAs pathName
Application.DisplayAlerts = True
 
End Sub

Sub CR_External_Budget_Est()
    CreateNewExcelmy (newNameBudget)
    
    For iCurrCol = 1 To 10
    WS.Columns(iCurrCol).ColumnWidth = 12
    Next

    'шапка
    WS.Cells(1, 1).Value = "CRID"
    WS.Cells(1, 2).Value = "* Cost Code Name"
    WS.Cells(1, 3).Value = "Cost Code"
    WS.Cells(1, 4).Value = "Category"
    WS.Cells(1, 5).Value = "Capex/Opex"
    WS.Cells(1, 6).Value = "* Budget Summ"
    WS.Cells(1, 7).Value = "* Year"
    WS.Cells(1, 8).Value = "Comment"
 
    'рамка и цвет ячеек
    With WS.Range("A1:H1")
        .Interior.Color = RGB(244, 236, 197)
        .Borders.LineStyle = xlContinuous
        .Borders.Color = RGB(204, 192, 133)
    End With
    
    'получение номера последней пустой строки
    Dim numStr As Long
    numStr = WS.Cells(Rows.Count, 1).End(xlUp).Row + 1
    
    'номер CR
    'WS.Range("A2:A5").Value = Range("C2").Value
    Dim startpstr As Integer
    Dim endpstr As Integer
    Dim lenpstr As Integer
    startpstr = InStr(Range("B2").Value, "[") + 3
    endpstr = InStr(Range("B2").Value, "]")
    lenpstr = endpstr - startpstr
    WS.Range("A2:A5").Value = Mid(Range("B2").Value, startpstr, lenpstr)
    
    'cost code
    Dim numlastCodeStr As Long
    Dim code As Integer
    code = "012111"
    
    WS.Range("C2:C5").Value = code
    numlastCodeStr = Worksheets("Skill").Cells(Rows.Count, 1).End(xlUp).Row
    
    For i = 1 To numlastCodeStr
        If Worksheets("Cost code").Cells(i, 1) = code Then
        WS.Range("B2:B5").Value = Worksheets("Cost code").Cells(i, 2).Value
        WS.Range("D2:D5").Value = Worksheets("Cost code").Cells(i, 3).Value
        WS.Range("E2:E5").Value = Worksheets("Cost code").Cells(i, 4).Value
        End If
    Next i
    
    WS.Range("B2:B5").WrapText = True
    WS.Range("D2:D5").WrapText = True

    '* Budget Summ
    tasks = Array(9, 12, 17, 22)
      
    For i = 0 To 3
    WS.Range("F" + CStr(i + 2)).Value = Range("D" + CStr(tasks(i))).Value
    Next i
    
    WS.Columns(6).ColumnWidth = 20
    
    'год
    WS.Range("G2:G5").Value = Year(Now)
    
    'WS.Range("G3").VerticalAlignment = xlTop
    
    'Comment
    tasks = Array(9, 12, 17, 22)
    
    For i = 0 To 3
    WS.Range("H" + CStr(i + 2)).Value = Range("E" + CStr(tasks(i))).Value
    Next i
    
    WS.Range("H2:H5").WrapText = True

    WS.Range("A1:K100").Font.Size = 8
    
    'рамка и цвет ячеек
    With WS.Range("A2:H5")
        .Interior.Color = RGB(255, 255, 255)
        .Borders.LineStyle = xlContinuous
        .Borders.Color = RGB(204, 192, 133)
    End With
    
    'Удалить строки с нулевой суммой
    For i = 0 To 3
    If WS.Range("F" + CStr(i + 2)).Value = "0" Then
        Set objRange = WS.Range("F" + CStr(i + 2)).EntireRow
        objRange.Delete
        i = i - 1
    End If
    Next i
    
    SaveNewFileExcel ("_PPM_upload_Budget")
    CloseFile
End Sub
 
Sub Create_two_files()
    Call CR_Mds_Estimation_upload
    Call CR_External_Budget_Est
End Sub