用VBA做日报

前言：有个同事需要每天做日报，但是电脑又因为种种原因用不了power query，所以就用VBA帮他写了一段代码
报表成品如下图：

其实东西并不多，只有8列数据，用power query大概也就15分钟的时间，可是VBA我写了整整1天啊~~

代码如下：
一、基础模块：
1、vlookup

Sub vmatch(list, cellstr, matchtab)

    'vlookup匹配，list是需要匹配的清单， cellstr是需要匹配的第一个单元格， matchtab是对应表
    If matchtab = "bm" Then
    ppbiao = "部门匹配表"
    ElseIf matchtab = "tc" Then ppbiao = "套餐匹配表"
    ElseIf matchtab = "qd" Then ppbiao = "渠道小类对应表"
    End If
    
    If list = "cdma" Then
    thismaxrow = Workbooks("cdma.xls").Worksheets("cdma").UsedRange.Rows.Count
    ElseIf list = "kd" Then thismaxrow = Workbooks("宽带叠加包.csv").Worksheets("宽带叠加包").UsedRange.Rows.Count
    End If

    ppmaxrow = Workbooks("！源数据（每天刷新）.xlsm").Worksheets(ppbiao).UsedRange.Rows.Count
    Range(cellstr).Select
    If matchtab = "bm" Then
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],'[！源数据（每天刷新）.xlsm]" & ppbiao & "'" & "!R1C1:R" & ppmaxrow & "C4,4,0)"
    ElseIf matchtab = "tc" Then
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],'[！源数据（每天刷新）.xlsm]" & ppbiao & "'" & "!R1C1:R" & ppmaxrow & "C3,3,0)"
    ElseIf matchtab = "qd" Then
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-12],'[！源数据（每天刷新）.xlsm]" & ppbiao & "'" & "!R1C1:R" & ppmaxrow & "C2,2,0)"
    End If
    
    Range(cellstr).Select
    temps = Mid(cellstr, 1, 1)
    Selection.AutoFill Destination:=Range(cellstr & ":" & temps & thismaxrow)
    Range(cellstr & ":" & temps & thismaxrow).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
End Sub

2、数据透视表

Sub cdmaPivot(kfmaxrow)

    'cdma清单处理好后的数据透视表
    Sheets.Add
    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        "Sheet1!R1C1:R" & kfmaxrow & "C23", Version:=6).CreatePivotTable TableDestination:= _
        "Sheet2!R3C1", TableName:="数据透视表1", DefaultVersion:=6
    Sheets("Sheet2").Select
    Cells(3, 1).Select
    
    With ActiveSheet.PivotTables("数据透视表1").PivotFields("统计日期")
        .Orientation = xlPageField
        .Position = 1
    End With
    With ActiveSheet.PivotTables("数据透视表1").PivotFields("套餐名称")
        .Orientation = xlPageField
        .Position = 1
    End With
    With ActiveSheet.PivotTables("数据透视表1").PivotFields("套餐分类")
        .Orientation = xlPageField
        .Position = 1
    End With
    With ActiveSheet.PivotTables("数据透视表1").PivotFields("所属部门")
        .Orientation = xlRowField
        .Position = 1
    End With
    ActiveSheet.PivotTables("数据透视表1").AddDataField ActiveSheet.PivotTables("数据透视表1" _
        ).PivotFields("订单号"), "计数项:订单号", xlCount
    
    '累计数据复制黏贴
    Range("A6:B6").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Windows("！源数据（每天刷新）.xlsm").Activate
    Sheets("做好的报表").Activate
    Range("A2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A1").Value = "所属部门"
    Range("B1").Value = "移动累计量"
    
    '累计合约数据复制黏贴
    Windows("cdma.xls").Activate
    ActiveSheet.PivotTables("数据透视表1").PivotFields("套餐分类").ClearAllFilters
    ActiveSheet.PivotTables("数据透视表1").PivotFields("套餐分类").CurrentPage = "核心套餐"
    Range("A6:B6").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("！源数据（每天刷新）.xlsm").Activate
    Sheets("做好的报表").Activate
    Range("D2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("D1").Value = "所属部门"
    Range("E1").Value = "合约累计量"
    
    '累计99数据复制黏贴
    Windows("cdma.xls").Activate
    ActiveSheet.PivotTables("数据透视表1").PivotFields("套餐分类").ClearAllFilters
    ActiveSheet.PivotTables("数据透视表1").PivotFields("套餐分类").CurrentPage = "(All)"
    ActiveSheet.PivotTables("数据透视表1").PivotFields("套餐名称").CurrentPage = "(All)"
    ActiveSheet.PivotTables("数据透视表1").PivotFields("套餐名称").CurrentPage = _
        "201802-天翼畅享99元套餐201802"
    Range("A6:B6").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("！源数据（每天刷新）.xlsm").Activate
    Range("G2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("G1").Value = "所属部门"
    Range("H1").Value = "99累计量"
        
    '累计30新移动数据复制黏贴
    thirtytc = "'2019年新移动30大流量套餐', '201809-天翼4G魔都畅享卡'"
    Windows("cdma.xls").Activate
    ActiveSheet.PivotTables("数据透视表1").PivotFields("套餐名称").CurrentPage = "(All)"
    With ActiveSheet.PivotTables("数据透视表1").PivotFields("套餐名称")
        For Each x In .PivotItems
            If InStr(thirtytc, x.Name) = 0 Then x.Visible = False
        Next
    End With
    Range("A6:B6").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("！源数据（每天刷新）.xlsm").Activate
    Range("J2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("J1").Value = "所属部门"
    Range("K1").Value = "30累计量"
    
    '获得昨天的日期，并以"43473"的格式
    yesterday = DateAdd("d", -1, Now)
    yesterday_f = Int(Format(yesterday, "General Number"))
    
    '昨日数据复制黏贴
    Windows("cdma.xls").Activate
    ActiveSheet.PivotTables("数据透视表1").PivotFields("套餐分类").ClearAllFilters
    ActiveSheet.PivotTables("数据透视表1").PivotFields("套餐名称").ClearAllFilters
    '如果没有昨天数据的话，就跳转到noyesterday并进行下一步
    On Error GoTo noyesterday
    ActiveSheet.PivotTables("数据透视表1").PivotFields("统计日期").CurrentPage = yesterday_f
    Range("A6:B6").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Windows("！源数据（每天刷新）.xlsm").Activate
    Sheets("做好的报表").Activate
    Range("M2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("M1").Value = "所属部门"
    Range("N1").Value = "移动昨日量"
    
    '昨日合约数据复制黏贴
    Windows("cdma.xls").Activate
    ActiveSheet.PivotTables("数据透视表1").PivotFields("套餐分类").ClearAllFilters
    ActiveSheet.PivotTables("数据透视表1").PivotFields("套餐名称").ClearAllFilters
    ActiveSheet.PivotTables("数据透视表1").PivotFields("套餐分类").CurrentPage = "核心套餐"
    Range("A6:B6").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("！源数据（每天刷新）.xlsm").Activate
    Sheets("做好的报表").Activate
    Range("P2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("P1").Value = "所属部门"
    Range("Q1").Value = "合约昨日量"
    
    '昨日99数据复制黏贴
    Windows("cdma.xls").Activate
    ActiveSheet.PivotTables("数据透视表1").PivotFields("套餐分类").ClearAllFilters
    ActiveSheet.PivotTables("数据透视表1").PivotFields("套餐名称").ClearAllFilters
    ActiveSheet.PivotTables("数据透视表1").PivotFields("套餐名称").CurrentPage = _
        "201802-天翼畅享99元套餐201802"
    Range("A6:B6").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("！源数据（每天刷新）.xlsm").Activate
    Range("S2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("S1").Value = "所属部门"
    Range("T1").Value = "99昨日量"
        
    '昨日30新移动数据复制黏贴
    thirtytc = "'2019年新移动30大流量套餐', '201809-天翼4G魔都畅享卡'"
    Windows("cdma.xls").Activate
    ActiveSheet.PivotTables("数据透视表1").PivotFields("套餐分类").ClearAllFilters
    ActiveSheet.PivotTables("数据透视表1").PivotFields("套餐名称").ClearAllFilters
    With ActiveSheet.PivotTables("数据透视表1").PivotFields("套餐名称")
        For Each x In .PivotItems
            If InStr(thirtytc, x.Name) = 0 Then x.Visible = False
        Next
    End With
    Range("A6:B6").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("！源数据（每天刷新）.xlsm").Activate
    Range("V2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("V1").Value = "所属部门"
    Range("W1").Value = "30昨日量"
    
    Exit Sub
    
noyesterday:
    MsgBox "没有找到昨天的数据，请检查清单！"
    

End Sub

3、把sheet里的东西清空

Sub clearsheet(sheetname)

    '把sheet里的东西清空
    Sheets(sheetname).Activate
    Cells.Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
End Sub

4、断开链接并保存日报（新名字）
这里我成品日报里用vlookup先做了匹配，所以只需要断开链接并另存为就可以简单完成比较复杂的操作了

Sub 日报成品(blank As String)

    '获得昨天的标准日期(1018这种格式)
    yesterday = DateAdd("d", -1, Now)
    yesterday_format = Format(yesterday, "mmdd") & ".xlsx"
    
    
    Application.DisplayAlerts = False
    
    '先刷新一次数据
    ActiveWorkbook.RefreshAll
    
    Path = Application.ThisWorkbook.Path
    Path_zxrb = Path & "\市东开放渠道日报.xlsx"
    Workbooks.Open (Path_zxrb)
    
    Sheets("门店维度").Select
    Cells.Select
    Range("A2").Activate
    ActiveWorkbook.BreakLink Name:= _
        Path & "\！源数据（每天刷新）.xlsm", Type:=xlExcelLinks
    Selection.Replace What:="#N/A", Replacement:="0", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    ChDir Path
    ActiveWorkbook.SaveAs Filename:= _
        Path & "\市东开放渠道日报" & yesterday_format, FileFormat:= _
        xlOpenXMLWorkbook, CreateBackup:=False
    
End Sub

5、把新的门店放到sheet"匹配表中缺的门店"中

Sub lack_store(kfmaxrow)

    '把新的门店放到sheet"匹配表中缺的门店"中
    Windows("cdma.xls").Activate
    Sheets("Sheet1").Activate
    Range("I1").Select
    Application.CutCopyMode = False
    Selection.AutoFilter
    On Error GoTo no_lackstore
    ActiveSheet.Range("$A$1:$W$" & kfmaxrow).AutoFilter Field:=23, Criteria1:="#N/A"
    Range("A1:W" & kfmaxrow).Select
    Range("I1").Activate
    Selection.Copy
    Windows("！源数据（每天刷新）.xlsm").Activate
    Sheets("匹配表中缺的门店").Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("A:E").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    Columns("B:L").Select
    Selection.Delete Shift:=xlToLeft
    Columns("C:G").Select
    Selection.Delete Shift:=xlToLeft
    Range("A1").Select
    temp_maxrow = ActiveSheet.UsedRange.Rows.Count
    ActiveSheet.Range("$A$1:$B$" & temp_maxrow).RemoveDuplicates Columns:=Array(1, 2), Header _
        :=xlNo
    If Range("A2").Value <> "" Then MsgBox "有新门店"
    
    Exit Sub
    
no_lackstore:
    Resume Next
End Sub

6、把新的套餐放到sheet"匹配表中缺的套餐"中

Sub lack_tc(kfmaxrow)

    '把新的套餐放到sheet"匹配表中缺的套餐"中
    Windows("cdma.xls").Activate
    Sheets("Sheet1").Activate
    ActiveSheet.ShowAllData
    On Error GoTo no_lacktc
    ActiveSheet.Range("$A$1:$W$" & kfmaxrow).AutoFilter Field:=9, Criteria1:="#N/A"
    Range("A1:W" & kfmaxrow).Select
    Selection.Copy
    Windows("！源数据（每天刷新）.xlsm").Activate
    Sheets("匹配表中缺的套餐").Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("A:G").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    Columns("B:P").Select
    Selection.Delete Shift:=xlToLeft
    Range("A1").Select
    temp_maxrow = ActiveSheet.UsedRange.Rows.Count
    ActiveSheet.Range("$A$1:$B$" & temp_maxrow).RemoveDuplicates Columns:=1, Header:=xlNo
    If Range("A2").Value <> "" Then MsgBox "有新套餐"
    
    Exit Sub
    
no_lacktc:
    Resume Next

End Sub

二、报表主程序

Sub 开放渠道做日报()

    '标准路径
    Path = Application.ThisWorkbook.Path
    ribaoPath = Path & "\市东开放渠道日报.xlsx"
    cdmaPath = Path & "\cdma.xls"
    kdPath = Path & "\宽带叠加包.csv"
    
    '清空"！源数据（每天刷新）.xlsm"里面几个sheet的数据
    Call clearsheet("做好的报表")
    Call clearsheet("匹配表中缺的门店")
    Call clearsheet("匹配表中缺的套餐")
    'Call clearsheet("报表中缺的门店")
    
    '打开cdma清单
    Workbooks.Open (cdmaPath)
    
    '获得cdma清单的最大行数
    cdmamaxrow = Worksheets("cdma").UsedRange.Rows.Count
    
    '把"统计日期"格式化
    Range("B2:B" & cdmamaxrow).Select
    Selection.NumberFormatLocal = "G/通用格式"
    
    '把"渠道管理细分"-Q列清空
    Range("Q2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    
    '把Q列匹配成新的渠道管理细分
    Range("Q2").Select
    Call vmatch("cdma", "Q2", "qd")
    
    '在“套餐名称”后增加一列，并改名为“套餐分类”
    Columns("I:I").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("I1").Select
    ActiveCell.FormulaR1C1 = "套餐分类"
    '把“V1”列改名为“合并部门”
    Range("V1").Select
    ActiveCell.FormulaR1C1 = "合并部门"
    Range("V2").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "=RC[-16]&RC[-4]"
    Range("V2").Select
    Selection.AutoFill Destination:=Range("V2:V" & cdmamaxrow)
    Range("V2:V" & cdmamaxrow).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    '对套餐进行vlookup
    Range("I2").Select
    Call vmatch("cdma", "I2", "tc")
    
    '把“W1”列改名为“所属部门”
    Range("W1").Select
    ActiveCell.FormulaR1C1 = "所属部门"
    
    '对部门进行vlookup
    Range("W2").Select
    Call vmatch("cdma", "W2", "bm")
    
    '提取开放渠道的清单
    ActiveSheet.Range("$A$1:$U$" & cdmamaxrow).AutoFilter Field:=15, Criteria1:="浦东电信局"
    ActiveSheet.Range("$A$1:$U$" & cdmamaxrow).AutoFilter Field:=18, Criteria1:="开放渠道"
    Range("A1:W" & cdmamaxrow).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Paste
    
    '获得开放渠道清单的最大行数
    kfmaxrow = ActiveSheet.UsedRange.Rows.Count
    
    '数据透视表基础设定
    Call cdmaPivot(kfmaxrow)
    
    '如果有新增门店和套餐，就放到相应的sheet里
    Call lack_store(kfmaxrow)
    Call lack_tc(kfmaxrow)
    
    '新部门添加
    new_agent_maxrow = Application.Workbooks("！源数据（每天刷新）.xlsm").Sheets("匹配表中缺的门店").UsedRange.Rows.Count
    old_agent_maxrow = Application.Workbooks("！源数据（每天刷新）.xlsm").Sheets("部门匹配表").UsedRange.Rows.Count
    If Application.Workbooks("！源数据（每天刷新）.xlsm").Sheets("匹配表中缺的门店").Range("A2").Value <> "" Then Workbooks("！源数据（每天刷新）.xlsm").Sheets("匹配表中缺的门店").Range("A2:B" & new_agent_maxrow).Copy Workbooks("！源数据（每天刷新）.xlsm").Sheets("部门匹配表").Range("B" & (old_agent_maxrow + 1))

    '新移动套餐添加
    new_cdma_maxrow = Application.Workbooks("！源数据（每天刷新）.xlsm").Sheets("匹配表中缺的套餐").UsedRange.Rows.Count
    old_cdma_maxrow = Application.Workbooks("！源数据（每天刷新）.xlsm").Sheets("套餐匹配表").Range("A65536").End(xlUp).Row
    If Application.Workbooks("！源数据（每天刷新）.xlsm").Sheets("匹配表中缺的套餐").Range("A2").Value <> "" Then Workbooks("！源数据（每天刷新）.xlsm").Sheets("匹配表中缺的套餐").Range("A2:A" & new_cdma_maxrow).Copy Workbooks("！源数据（每天刷新）.xlsm").Sheets("套餐匹配表").Range("A" & (old_cdma_maxrow + 1))
    
    '做成日报成品
    Call 日报成品(1)
    
End Sub