Malicious Office (OLE) / .DOC — malware analysis report

Attribute VB_Name = "Sheet1"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
Attribute VB_Control = "cmbRefresh, 92, 0, MSForms, CommandButton"
Attribute VB_Control = "cmbCreateTVplan, 97, 1, MSForms, CommandButton"
Attribute VB_Control = "cmbClientFile, 98, 2, MSForms, CommandButton"
Attribute VB_Control = "cmbORDRep, 120, 3, MSForms, CommandButton"
Attribute VB_Control = "cmbBatsoftReach, 122, 4, MSForms, CommandButton"

Option Explicit


Private Sub cmbBatsoftReach_Click()

    Create_Batsoft_Reach_tables

End Sub

Private Sub cmbCreateTVplan_Click()

    Create_TV_plan


End Sub
 

Private Sub cmbClientFile_Click()
    
    Create_Client_File
    
End Sub


Private Sub cmbORDRep_Click()

    Create_TV_order_report

End Sub

Private Sub cmbRefresh_Click()
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Refresh_Spot_by_spot_table
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub






Attribute VB_Name = "Sheet7"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
Attribute VB_Control = "cmbLoadCHplans, 1, 0, MSForms, CommandButton"
Attribute VB_Control = "cmbWrbCHprogramm, 2, 1, MSForms, ComboBox"

Option Explicit

Private Sub cmbLoadCHplans_Click()

    Format_data_Batsoft "CH_program_plan", LNG_COLOR_CHANSHEETS, 7, "A", _
                        "B", "C", "F", "A5", "A3", cmbWrbCHprogramm.Value

End Sub

Private Sub Worksheet_Activate()

    While cmbWrbCHprogramm.ListCount <> 0
        cmbWrbCHprogramm.RemoveItem 0
    Wend
    
    Dim wrb As Excel.Workbook
    
    For Each wrb In Application.Workbooks
        cmbWrbCHprogramm.AddItem wrb.Name
    Next

End Sub




Attribute VB_Name = "Sheet10"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
Attribute VB_Control = "cmbLoadPlacedSpots, 1, 0, MSForms, CommandButton"
Attribute VB_Control = "cmbWrbPlacedSpots, 2, 1, MSForms, ComboBox"

Option Explicit

Private Sub cmbLoadPlacedSpots_Click()

    Format_data_Batsoft "placed_spots", LNG_COLOR_CHANSHEETS, 7, "A", _
                        "B", "C", "F", "A5", "A3", cmbWrbPlacedSpots.Value
    
End Sub

Private Sub Worksheet_Activate()

    While cmbWrbPlacedSpots.ListCount <> 0
        cmbWrbPlacedSpots.RemoveItem 0
    Wend
    
    Dim wrb As Excel.Workbook
    
    For Each wrb In Application.Workbooks
        cmbWrbPlacedSpots.AddItem wrb.Name
    Next

End Sub




Attribute VB_Name = "Sheet6"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
Attribute VB_Control = "cmbSortRTG, 3, 0, MSForms, CommandButton"
Attribute VB_Control = "cmbClearRTG, 4, 1, MSForms, CommandButton"

Option Explicit

Private Sub cmbClearRTG_Click()

    ThisWorkbook.ActiveSheet.Range("RTG_table_planned").ClearContents

End Sub

Private Sub cmbSortRTG_Click()

    Format_RTG ThisWorkbook.ActiveSheet, 10, "D", "RTG_table_planned"

End Sub

Attribute VB_Name = "Sheet18"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
Attribute VB_Control = "cmbAdd, 1, 0, MSForms, CommandButton"
Attribute VB_Control = "cmbCreateFiles, 2, 1, MSForms, CommandButton"
Option Explicit

Private Sub cmbAdd_Click()

    Copy_data_into_DB

End Sub

Private Sub cmbCreateFiles_Click()

    Create_files_for_IC_FCB_program
    
End Sub

Attribute VB_Name = "Sheet17"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
Attribute VB_Control = "cmbAdFact, 20, 0, MSForms, CommandButton"
Attribute VB_Control = "cmbCreate, 21, 1, MSForms, CommandButton"
Attribute VB_Control = "cmbPCADelete, 22, 2, MSForms, CommandButton"

Option Explicit

Private Sub cmbAdFact_Click()

    Format_data_PaloMARS

End Sub


Private Sub cmbCreate_Click()

    PCA_create

End Sub

Private Sub cmbPCADelete_Click()

    PCA_delete

End Sub

Attribute VB_Name = "Sheet15"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
Attribute VB_Control = "cmbPCAClient, 2, 0, MSForms, CommandButton"

Option Explicit

Private Sub cmbPCAClient_Click()

    PCA_create_client_file

End Sub

Attribute VB_Name = "ThisWorkbook"
Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet9"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet19"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet2"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet4"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet20"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet8"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet3"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet5"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet12"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet21"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet16"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet13"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Chart1"
Attribute VB_Base = "0{00020821-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet14"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "TV_plan_macroses"
Option Explicit

'Macroses in this module:

'sub Create_TV_plan
'sub Create_Client_File
'sub Refresh_Spot_by_spot_table


Sub Create_TV_plan()


    On Error GoTo ExitSub
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False
    
        ' Makes sure that the statusbar is visible.
    Application.DisplayStatusBar = True
        ' Enter your message for the statusbar:
    Application.StatusBar = "Now processing...."
    
    Dim shtTVplan As Excel.Worksheet
    Dim shtCHplan As Excel.Worksheet
    
    Set shtTVplan = ThisWorkbook.Worksheets(STR_TVPLAN_SHTNAME)
    Set shtCHplan = ThisWorkbook.Worksheets(STR_CHPLAN_SHTNAME)
    
    Dim lngCHplanRowCount As Long
    lngCHplanRowCount = shtCHplan.Range(STR_CHPLAN_STARTCOLUMN & LNG_CHPLAN_STARTROW).CurrentRegion.Rows.Count
    
        'create copy of template
    Dim wrbNewTVplan As Excel.Workbook, strFileName As String
    Dim wrb As Excel.Workbook, strSavePathName As String, boolFileOpened As Boolean
    
    boolFileOpened = True
    While boolFileOpened
        strFileName = " _selection.xls"
        strSavePathName = Application.GetSaveAsFilename( _
                                   InitialFileName:=strFileName _
                                   , fileFilter:="Excel files (*.xls), *.xls") _

        boolFileOpened = False
                    'check if file, with name we are trying to save, is open
                    'if TRUE offer to choose new name again
        For Each wrb In Application.Workbooks
            If wrb.FullName = strSavePathName Then
                MsgBox "File " & strSavePathName & " is already open!" & _
                                    " Choose different name!", vbOKOnly
                boolFileOpened = True
            End If
        Next
    Wend
    
    If strSavePathName <> "False" Then
        ThisWorkbook.SaveCopyAs Filename:=strSavePathName
        Application.Workbooks.Open Filename:=strSavePathName, UpdateLinks:=3, ReadOnly:=False
    Else
        MsgBox "Error!", vbInformation
        GoTo ExitSub
    End If
    
    Set wrbNewTVplan = ActiveWorkbook
    wrbNewTVplan.Colors = ThisWorkbook.Colors
    
'        'delete PCA sheets
    Dim sht As Worksheet, i As Long
'    For Each sht In wrbNewTVplan.Worksheets
'        If sht.Tab.ColorIndex = LNG_COLOR_PCA Then
'            sht.Delete
'        End If
'    Next
'
'        'remove named ranges that begins with "pca_"
'    For i = wrbNewTVplan.Names.Count - 1 To 1 Step -1
'        If VBA.LCase(wrbNewTVplan.Names.Item(i).Name) Like "pca_*" Then
'            wrbNewTVplan.Names.Item(i).Delete
'        End If
'    Next
    
    Dim shtTVplanNew As Excel.Worksheet
    Dim shtCHplanNew As Excel.Worksheet
    Set shtTVplanNew = wrbNewTVplan.Worksheets(STR_TVPLAN_SHTNAME)
    Set shtCHplanNew = wrbNewTVplan.Worksheets(STR_CHPLAN_SHTNAME)
    
        'store name of template file
    shtCHplanNew.Range("K1").Value = ThisWorkbook.FullName
    shtCHplanNew.Range("K1").Font.Color = vbWhite
    shtCHplanNew.Range("K2").Value = ThisWorkbook.Name
    shtCHplanNew.Range("K2").Font.Color = vbWhite

    
        'store link to range with cell with needed captions
        'it is easy to get row or column adress from any range
    Dim rngPlChanCell As Excel.Range, rngCHChanCell As Excel.Range
    Dim rngPlDateCell As Excel.Range, rngCHDateCell As Excel.Range
    Dim rngPlBreakCell As Excel.Range, rngCHBreakCell As Excel.Range
    
            'looking for TV plan captions
    Dim rngTVplanNewCaptions As Excel.Range, arrTVplanCaptions()
    Set rngTVplanNewCaptions = shtTVplanNew.Range(STR_TVPLAN_STARTCOLUMN & LNG_FORMULA_ROW - 1 & ":" _
                                                                & STR_TVPLAN_ENDCOLUMN & LNG_FORMULA_ROW - 1)
    arrTVplanCaptions() = rngTVplanNewCaptions
    Const STR_CHAN_COLNAME As String = "channel"
    Const STR_DATE_COLNAME As String = "date"
    Const BREAK_COLNAME As String = "break id"
    
    For i = LBound(arrTVplanCaptions, 2) To UBound(arrTVplanCaptions, 2)
        If VBA.LCase(arrTVplanCaptions(1, i)) Like STR_CHAN_COLNAME Then
            Set rngPlChanCell = rngTVplanNewCaptions(1, i)
        ElseIf VBA.LCase(arrTVplanCaptions(1, i)) Like STR_DATE_COLNAME & "*" Then
            Set rngPlDateCell = rngTVplanNewCaptions(1, i)
        ElseIf VBA.LCase(arrTVplanCaptions(1, i)) Like "*" & BREAK_COLNAME & "*" Then
            Set rngPlBreakCell = rngTVplanNewCaptions(1, i)
        End If
    Next
    
            'looking for CH plan captions
    Dim rngCHplanCaptions As Excel.Range, arrCHplanCaptions()
    Set rngCHplanCaptions = shtCHplanNew.Range(STR_CHPLAN_STARTCOLUMN & LNG_CHPLAN_STARTROW - 2 & ":" & _
                                                                        STR_CHPLAN_ENDCOLUMN & LNG_CHPLAN_STARTROW - 2)
    arrCHplanCaptions() = rngCHplanCaptions
    
    For i = LBound(arrCHplanCaptions, 2) To UBound(arrCHplanCaptions, 2)
        If VBA.LCase(arrCHplanCaptions(1, i)) Like STR_CHAN_COLNAME & "*" Then
            Set rngCHChanCell = rngCHplanCaptions(1, i)
        ElseIf VBA.LCase(arrCHplanCaptions(1, i)) Like STR_DATE_COLNAME & "*" Then
            Set rngCHDateCell = rngCHplanCaptions(1, i)
        ElseIf VBA.LCase(arrCHplanCaptions(1, i)) Like "*" & BREAK_COLNAME & "*" Then
            Set rngCHBreakCell = rngCHplanCaptions(1, i)
        End If
    Next
    
    shtTVplanNew.Rows(LNG_TVPLAN_STARTROW & ":" & LNG_TVPLAN_STARTROW + lngCHplanRowCount - 1).Insert
    
            'copy LNG_FORMULA_ROW over inserted rows
    Dim lngLastCopiedRow As Long
    lngLastCopiedRow = LNG_TVPLAN_STARTROW - 1
    
            'split copied range into parts with 500 records, 'cause sometimes copy doesn't work with
            'large ranges
    For i = 1 To lngCHplanRowCount \ 500
        shtTVplanNew.Range(STR_TVPLAN_STARTCOLUMN & LNG_FORMULA_ROW & ":" & STR_TVPLAN_ENDCOLUMN & LNG_FORMULA_ROW).Copy _
            Destination:=shtTVplanNew.Range(STR_TVPLAN_STARTCOLUMN & lngLastCopiedRow + 1 & ":" _
                                        & STR_TVPLAN_ENDCOLUMN & lngLastCopiedRow + 501)
        Application.CutCopyMode = False
        lngLastCopiedRow = lngLastCopiedRow + 500
    Next
    
    shtTVplanNew.Range(STR_TVPLAN_STARTCOLUMN & LNG_FORMULA_ROW & ":" & STR_TVPLAN_ENDCOLUMN & LNG_FORMULA_ROW).Copy _
        Destination:=shtTVplanNew.Range( _
                    STR_TVPLAN_STARTCOLUMN & LNG_TVPLAN_STARTROW + lngCHplanRowCount - (lngCHplanRowCount Mod 500) & ":" _
                    & STR_TVPLAN_ENDCOLUMN & LNG_TVPLAN_STARTROW + lngCHplanRowCount - 1)
    Application.CutCopyMode = False
    
    
        'copy Chan/Date/Break ID from CH program into TV plan
            'copy Channels
    shtCHplanNew.Range( _
                    rngCHChanCell.Offset(2, 0).Address(False, False, xlA1) & ":" & _
                    rngCHChanCell.Offset(1 + lngCHplanRowCount, 0).Address(False, False, xlA1)).Copy
    rngPlChanCell.Offset(3, 0).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone, False, False
    Application.CutCopyMode = False
            'copy Dates
    shtCHplanNew.Range( _
                    rngCHDateCell.Offset(2, 0).Address(False, False, xlA1) & ":" & _
                    rngCHDateCell.Offset(1 + lngCHplanRowCount, 0).Address(False, False, xlA1)).Copy
    rngPlDateCell.Offset(3, 0).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone, False, False
    Application.CutCopyMode = False
            'copy Break IDs
    shtCHplanNew.Range( _
                    rngCHBreakCell.Offset(2, 0).Address(False, False, xlA1) & ":" & _
                    rngCHBreakCell.Offset(1 + lngCHplanRowCount, 0).Address(False, False, xlA1)).Copy
    rngPlBreakCell.Offset(3, 0).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone, False, False
    Application.CutCopyMode = False
    
    Application.Calculation = xlCalculationAutomatic
    Application.Calculation = xlCalculationManual
    
        'convert all formulas into values
    PasteValues shtTVplanNew.Rows(LNG_FORMULA_ROW + 2 & ":" & (LNG_FORMULA_ROW + lngCHplanRowCount + 1))
    
        'copy some formulas back (depend on cell coloring)
    For i = 1 To rngTVplanNewCaptions.Columns.Count
        If rngTVplanNewCaptions(1, i).Offset(1, 0).Cells.Interior.ColorIndex = LNG_COLOR_FORMULAS _
        Then
            rngTVplanNewCaptions(1, i).Offset(1, 0).Copy
            rngTVplanNewCaptions(1, i).Offset(3, 0).Resize(lngCHplanRowCount).PasteSpecial _
                                                xlPasteFormulas, xlPasteSpecialOperationNone, False, False
            Application.CutCopyMode = False
        End If
    Next
    
    
    shtTVplanNew.Range(STR_TVPLAN_STARTCOLUMN & LNG_TVPLAN_STARTROW).CurrentRegion.EntireRow.Sort _
        key1:=rngPlChanCell, order1:=xlAscending, _
        key2:=rngPlDateCell, order2:=xlAscending, _
        key3:=rngPlBreakCell.Offset(, -2), order3:=xlAscending
    
        'make buttons visible
    With wrbNewTVplan.Worksheets(STR_TVPLAN_SHTNAME)
        .Shapes("cmbRefresh").Visible = True
        .Shapes("cmbCreateTVplan").Visible = False
        .Shapes("cmbClientFile").Visible = True
        .Shapes("cmbORDRep").Visible = True
        .Shapes("cmbBatsoftReach").Visible = True
    End With
    
    With wrbNewTVplan.Worksheets(STR_PMARS_SHTNAME)
        .Shapes("cmbCreate").Visible = True
        .Shapes("cmbPCADelete").Visible = True
    End With

        'refresh and format pivot
    With wrbNewTVplan.Worksheets(STR_SHTSTR_PIVOT_NAME)
        .PivotTables(STR_PIVOT_NAME).PivotCache.Refresh
        .Range(STR_PIVOT_TIMECOL & ":" & STR_PIVOT_TIMECOL).NumberFormat = "[$-F400]h:mm:ss AM/PM"
        .Range("A1").EntireRow.EntireColumn.AutoFit
    End With
    

ExitSub:

    On Error Resume Next
    
    Set rngCHBreakCell = Nothing
    Set rngCHDateCell = Nothing
    Set rngCHChanCell = Nothing
    Set rngCHplanCaptions = Nothing
    Set rngPlBreakCell = Nothing
    Set rngPlDateCell = Nothing
    Set rngPlChanCell = Nothing
    Set rngTVplanNewCaptions = Nothing
    Set shtCHplanNew = Nothing
    Set shtTVplanNew = Nothing
    Set shtCHplan = Nothing
    Set shtTVplan = Nothing
    Set wrbNewTVplan = Nothing
    
        ' When your code is finished, reset the statusbar:
    Application.StatusBar = False
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

Sub Create_Client_File()


    On Error GoTo ExitSub
    
'    '----
'    Dim strStartTime As String, strEndTime As String
'    strStartTime = Time()
'    '----
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False
    
        ' Makes sure that the statusbar is visible.
    Application.DisplayStatusBar = True
        ' Enter your message for the statusbar:
    Application.StatusBar = "Now processing...."
    
        'refresh spot by spot table before creating client file
'    Refresh_Spot_by_spot_table
    
    Application.Calculation = xlCalculationAutomatic
    Application.Calculation = xlCalculationManual

    Dim MAX_COLUMN_COUNT As Long
    MAX_COLUMN_COUNT = ConvLetterIntoNum(STR_TVPLAN_ENDCOLUMN)
    
        'store reference to TV plan with formulas
    Dim wrbTVplan As Excel.Workbook
    Set wrbTVplan = ThisWorkbook
    
        'create copy of TV plan
    Dim wrbClientFile As Excel.Workbook
    
    wrbTVplan.Worksheets.Copy
    Set wrbClientFile = ActiveWorkbook
    
        'save "client" file in the folder with "selection" file
    On Error Resume Next
        'create file name
    Dim strPath As String, strProjKod As String
    If InStrRev(ThisWorkbook.Worksheets(STR_TVPLAN_SHTNAME).Range("proj_project_name"), "/") <> 0 _
    Then
        strProjKod = VBA.Mid( _
            ThisWorkbook.Worksheets(STR_TVPLAN_SHTNAME).Range("proj_project_name"), _
            1, _
            InStrRev(ThisWorkbook.Worksheets(STR_TVPLAN_SHTNAME).Range("proj_project_name"), "/") - 1 _
            )
    Else
        strProjKod = ThisWorkbook.Worksheets(STR_TVPLAN_SHTNAME).Range("proj_project_name")
    End If
    
    'calculate Vesion' number
    Dim lngVer As Long
    lngVer = ThisWorkbook.Worksheets(STR_CHPLAN_SHTNAME).Range(STR_RNGNAME_VERSION).Value + 1
    
    
    strPath = ThisWorkbook.Path & "\" & _
        "LV_IC_mpl_TV_" & _
        strProjKod _
        & "_v" & VBA.Format(lngVer, "00") & "_" & _
        Application.WorksheetFunction.Text( _
            ThisWorkbook.Worksheets(STR_TVPLAN_SHTNAME).Range("proj_date_begin").Value, "yyyymmdd") _
        & "to" & _
        Application.WorksheetFunction.Text( _
            ThisWorkbook.Worksheets(STR_TVPLAN_SHTNAME).Range("proj_date_end").Value, "yyyymmdd") _
        & "_" & _
        ThisWorkbook.Worksheets(STR_TVPLAN_SHTNAME).Range("proj_campaign_name") & _
        ".xls"
        
    Dim varExcelVersion As Variant
    varExcelVersion = Application.Version
    
    If VBA.Left(varExcelVersion, 2) = "12" _
    Then
        'Excel 2007
        wrbClientFile.SaveAs Filename:=strPath, FileFormat:=xlExcel8
    Else
        'Excel 2003
        wrbClientFile.SaveAs Filename:=strPath, FileFormat:=xlNormal
    End If
    
    'add +1 to version number in template
    ThisWorkbook.Worksheets(STR_CHPLAN_SHTNAME).Range(STR_RNGNAME_VERSION).Value = lngVer
    
    On Error GoTo ExitSub
    
        'copy colors from selection file
    wrbClientFile.Colors = ThisWorkbook.Colors
    
            'convert all formulas to values on TV plan sheet
    Dim strTVtableRange As String, arrTmp(), shtTVplan As Worksheet
    Dim rngStartCopyCell As Range, rngLastCopyCell As Range, i As Long
    
    Set shtTVplan = wrbClientFile.Worksheets(STR_TVPLAN_SHTNAME)
    Set rngStartCopyCell = shtTVplan.Range("a1")
    Set rngLastCopyCell = rngStartCopyCell.SpecialCells(xlLastCell)
    
    If rngLastCopyCell.Row > 2500 Then
        For i = 1 To rngLastCopyCell.Row \ 2500
            PasteValues shtTVplan.Range( _
                        ConvNumIntoLetter(rngStartCopyCell.Column) & (rngStartCopyCell.Row + 2500 * (i - 1)) _
                            & ":" & _
                        ConvNumIntoLetter(rngLastCopyCell.Column) & (rngStartCopyCell.Row + 2500 * i) _
                                        )
        Next
        PasteValues shtTVplan.Range( _
                    ConvNumIntoLetter(rngStartCopyCell.Column) & (rngStartCopyCell.Row + 2500 * i + 1) _
                        & ":" & _
                    rngLastCopyCell.Address)
    Else
        PasteValues shtTVplan.Range(rngStartCopyCell.Address & ":" & rngLastCopyCell.Address)
    End If
    
    
        'store reference to row with captions
    Dim rngCaptions As Excel.Range
    Set rngCaptions = wrbClientFile.Worksheets(STR_TVPLAN_SHTNAME) _
                        .Range(STR_TVPLAN_STARTCOLUMN & LNG_TVPLAN_STARTROW).Offset(-3).Resize(, MAX_COLUMN_COUNT)

        'delete LNG_FORMULA_ROW
    wrbClientFile.Worksheets(STR_TVPLAN_SHTNAME).Rows(LNG_FORMULA_ROW).Delete

        '--- remove non-checked row ---
            'find columns for sorting data
    Dim rngCodeColCaption As Range, rngDateColCaption As Range
    Dim rngTimeColCaption As Range, rngChanColCaption As Range
    
    For i = MAX_COLUMN_COUNT To 1 Step -1
        If rngCaptions(1, i).Value = STR_CODE_COLNAME _
        Then
            Set rngCodeColCaption = rngCaptions(1, i)
        ElseIf rngCaptions(1, i).Value = STR_CHAN_COLNAME _
        Then
            Set rngChanColCaption = rngCaptions(1, i)
        ElseIf rngCaptions(1, i).Value = STR_DATE_COLNAME _
        Then
            Set rngDateColCaption = rngCaptions(1, i)
        ElseIf rngCaptions(1, i).Value = #5:00:00 AM# _
        Then
            Set rngTimeColCaption = rngCaptions(1, i)
        End If
    Next

        'sort by code only if "code" column was found
    If Not rngCodeColCaption Is Nothing _
    Then
            'sort whole table by clip code
        rngCaptions.Offset(2).CurrentRegion.EntireRow.Sort _
                    key1:=rngCodeColCaption
        rngCaptions.Offset(2).CurrentRegion.EntireRow.Interior.Color = vbWhite
        
            'delete non-checked rows
        Dim lngLastChkedRow As Long, lngLastRow As Long
        lngLastChkedRow = rngCodeColCaption.Offset(2).End(xlDown).Row
        lngLastRow = rngCodeColCaption.Offset(2, 1).End(xlDown).Row
        
        If lngLastChkedRow <> lngLastRow _
        Then
            wrbClientFile.Worksheets(STR_TVPLAN_SHTNAME).Rows(lngLastChkedRow + 1 & ":" & lngLastRow).Delete
        End If
        
            'sort by chan/date/time only if corresponding columns was found
        If Not rngChanColCaption Is Nothing And _
            Not rngDateColCaption Is Nothing And _
            Not rngTimeColCaption Is Nothing _
        Then
            rngCaptions.Offset(2).CurrentRegion.EntireRow.Sort _
                key1:=rngChanColCaption, order1:=xlAscending, _
                key2:=rngDateColCaption, order2:=xlAscending, _
                key3:=rngTimeColCaption, order3:=xlAscending
        Else
            MsgBox "Check table captions! Couldn't sort checked rows!"
        End If
    Else
        MsgBox "Check table captions! Couldn't delete non-checked rows!"
    End If
        '-------------------------------------

        're-calculate formulas
    Application.Calculation = xlCalculationAutomatic
    Application.Calculation = xlCalculationManual
    
            
            'refresh and format pivot
    With wrbClientFile.Worksheets(STR_SHTSTR_PIVOT_NAME)
        .PivotTables(STR_PIVOT_NAME).PivotCache.Refresh
        .Range(STR_PIVOT_TIMECOL & ":" & STR_PIVOT_TIMECOL).NumberFormat = "[$-F400]h:mm:ss AM/PM"
        .Range("A:A").EntireColumn.AutoFit
    End With
    
    Application.Wait Now + TimeValue("0:00:01")
        
        'convert all formulas to values
    Dim sht As Excel.Worksheet
    For Each sht In wrbClientFile.Worksheets
        If sht.Tab.ColorIndex = LNG_COLOR_CLIENTSHEETS And sht.Name <> STR_SHTSTR_PIVOT_NAME _
        Then

            strTVtableRange = "A1:" & sht.Range("A1").SpecialCells(xlLastCell).Address
            sht.AutoFilterMode = False
            
            PasteValues sht.Range(strTVtableRange)

        ElseIf sht.Tab.ColorIndex = LNG_COLOR_CLIENTSHEETS And sht.Name = STR_SHTSTR_PIVOT_NAME _
        Then
        
            strTVtableRange = "A1:" & sht.Range("A1").SpecialCells(xlLastCell).Address
            sht.AutoFilterMode = False
            
            PasteValues sht.Range(strTVtableRange)
        End If
    Next
    
   
            'delete macroses from "TV plan" & "Total media" sheets
    If Not ProtectedVBProject(wrbClientFile) _
    Then
        DeleteModuleContent wrbClientFile, "Sheet1" 'tv plan
    End If
    
        'delete all sheets except Client Sheets
    For Each sht In wrbClientFile.Worksheets
        sht.Activate
        SendKeys "^{Home}", True
        If sht.Tab.ColorIndex <> LNG_COLOR_CLIENTSHEETS _
        Then
            sht.Delete
        End If
    Next

    With wrbClientFile.Worksheets(STR_TVPLAN_SHTNAME)
            'delete table with budget split
        .Range(STR_BDGSPLIT_TABLE).ClearContents
    
            'delete buttons
        .Shapes("cmbRefresh").Delete
        .Shapes("cmbClientFile").Delete
        .Shapes("cmbORDRep").Delete
        .Shapes("cmbBatsoftReach").Delete
        .Shapes("cmbCreateTVplan").Delete
    
                'delete all columns where captions are in green color
        For i = MAX_COLUMN_COUNT To 1 Step -1

            If rngCaptions(1, i).Font.ColorIndex = LNG_COLOR_CAPTIONS _
            Then
                rngCaptions(1, i).EntireColumn.Delete
            End If
        Next
    
            'open "TV plan" sheet
        .Activate
            'hide all outlined columns and rows
        .Outline.ShowLevels RowLevels:=1, ColumnLevels:=1
    End With
    
            'remove named ranges
    For i = wrbClientFile.Names.Count To 1 Step -1
        If Not VBA.LCase(wrbClientFile.Names.Item(i).Name) Like "*print_*" Then
            wrbClientFile.Names.Item(i).Delete
        End If
    Next
    
            'convert charts into picture
    With wrbClientFile.Worksheets(STR_SHTCHART_NAME)
        .Select
        .Shapes.Range(Array("TRPBYCH", "FReqD", "TRPBYDays", "TRPBYWEEKD", _
                    "TRPBYWEEKS", "TRPBYTZ", "TRPBYPROG", "TRPCPP", "GRPCPP")).Select
        Selection.Cut
        Range("A1").Select
        .PasteSpecial Format:="Picture (Enhanced Metafile)", Link:=False, DisplayAsIcon:=False
        Selection.ShapeRange.IncrementTop 145
        Selection.ShapeRange.IncrementLeft 55
    End With
    
    shtTVplan.Select
    
    wrbClientFile.Save
    

    
ExitSub:
    
    On Error Resume Next
    
    Set rngLastCopyCell = Nothing
    Set rngStartCopyCell = Nothing
    Set rngCodeColCaption = Nothing
    Set rngCaptions = Nothing
    Set shtTVplan = Nothing
    Set wrbClientFile = Nothing
    Set wrbTVplan = Nothing
    
            ' When your code is finished, reset the statusbar:
    Application.StatusBar = False
    
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
'    strEndTime = Time()
'    MsgBox "Macro working time: " & strStartTime & " : " & strEndTime, vbInformation
'


End Sub

Sub Refresh_Spot_by_spot_table()

    On Error GoTo ExitSub
    
    Dim MAX_COLUMN_COUNT As Long
    MAX_COLUMN_COUNT = ConvLetterIntoNum(STR_TVPLAN_ENDCOLUMN)
    
    Dim rngFstRow As Excel.Range, shtTVplan As Excel.Worksheet
    Set shtTVplan = Application.ThisWorkbook.Worksheets(STR_TVPLAN_SHTNAME)
    Set rngFstRow = shtTVplan.Range(STR_TVPLAN_STARTCOLUMN & LNG_TVPLAN_STARTROW)
    
   
        'proof if TV plan is not empty
    If rngFstRow.Value <> "" _
    Then
    
        'look for last row
        Dim rngEndRow As Excel.Range
        Set rngEndRow = shtTVplan.Range(STR_TVPLAN_STARTCOLUMN & ":" & STR_TVPLAN_STARTCOLUMN). _
                                    EntireColumn.Find("Total:").Offset(-1)
        If rngEndRow Is Nothing Then
            MsgBox "Couldn't find 'Total:'!", vbCritical
            GoTo ExitSub
        End If
        
        While rngEndRow.Value = ""
            Set rngEndRow = rngEndRow.Offset(-1) 'value =chan name
        Wend
    
        'save autofilter settings
   
        If shtTVplan.AutoFilterMode _
        Then
            On Error Resume Next
            
            Dim lngItemCnt As Long, arrAutofilter(), i As Long, rngAutofilter As Excel.Range
            lngItemCnt = shtTVplan.AutoFilter.Filters.Count
    
            ReDim arrAutofilter(1 To lngItemCnt, 1 To 3)
            Set rngAutofilter = shtTVplan.AutoFilter.Range
            With shtTVplan.AutoFilter.Filters
                For i = 1 To lngItemCnt
                    If .Item(i).On Then
                        arrAutofilter(i, 1) = .Item(i).Criteria1
                        If .Item(i).Operator Then
                            arrAutofilter(i, 2) = .Item(i).Operator
                            arrAutofilter(i, 3) = .Item(i).Criteria2
                        End If
                    End If
                Next
            End With
            shtTVplan.AutoFilterMode = False
        
            On Error GoTo ExitSub
        End If
        
        Dim rngFormulaRow As Excel.Range, strCellAddress As String
        Set rngFormulaRow = shtTVplan.Range(STR_TVPLAN_STARTCOLUMN & LNG_FORMULA_ROW & ":" & STR_TVPLAN_ENDCOLUMN & LNG_FORMULA_ROW)
        
        With shtTVplan.Range(rngFstRow.Address & ":" & rngEndRow.Address)
            
            For i = 1 To MAX_COLUMN_COUNT
                strCellAddress = ConvNumIntoLetter(i) & 1
                If rngFormulaRow.Range(strCellAddress).HasFormula _
                Then
                        'copy and paste only formulas from Formula Row
                    rngFormulaRow.Range(strCellAddress).Copy
                    .Offset(, i - 1).PasteSpecial xlPasteFormulas, xlPasteSpecialOperationNone, False, False
                    .Offset(, i - 1).PasteSpecial xlPasteFormats, xlPasteSpecialOperationNone, False, False
                    
                    Application.CutCopyMode = False
                End If
…