【VBA】【一天的心血，收藏一下】一键生成报表2

版权声明： https://blog.csdn.net/qq_27469815/article/details/83583054

Public batch$
Sub crAddReport()
    '获取窗体单选框选择
    UserForm1.Show
    If UserForm1.OptionButton1.Value = True Then
        batch = "一"
    ElseIf UserForm1.OptionButton2.Value = True Then
        batch = "二"
    ElseIf UserForm1.OptionButton3.Value = True Then
        batch = "三"
    End If

    t1 = Timer
    Application.ScreenUpdating = False
        Call importLog '引用模块2的方法
        Call findBrokenStation '引用模块2的方法
        Call nowCrReport2
        Call crFile2
    Application.ScreenUpdating = True
    t2 = Timer
    MsgBox "己完成，运行时间 = " & (t2 - t1) * 1000 & " ms"

End Sub

Sub crFile2()

    Worksheets("结果统计-新增").Copy
    With ActiveSheet
        .Select
        .Columns("A:E").Delete
        .Shapes.Range(Array("Picture 1")).Delete
        [I1] = "执行结果"
        [I2] = "断X"
        [I3] = "配齐4个XX"
        [I4] = "无XX数据"
        [I5] = "因XXXX未配齐"
        [I6] = "总计"

        [J1] = "数量"
        [J2].formula = "=COUNTIF(E:E,I2)"
        [J3].formula = "=COUNTIF(E:E,I3)"
        [J4].formula = "=COUNTIF(E:E,I4)"
        [J5].formula = "=COUNTIF(E:E,I5)"
        [J6].formula = "=SUM(J2:J5)"
    End With
    '格式化
    Call formatting2
    '选择批次
    
    ActiveWorkbook.SaveAs "XXX测量配置结果_" & Month(Date) & "月第" & batch & "组.xlsx"
    
End Sub

Sub nowCrReport2()
    Application.ScreenUpdating = False
    Dim d As Object, rng As Range
    Set dCity = CreateObject("Scripting.Dictionary")
    Set dOSS = CreateObject("Scripting.Dictionary")
    With Worksheets("ip对应地市名工具")
    For i = 1 To .[A65536].End(xlUp).Row
        dCity.add .Cells(i, 1).Value, .Cells(i, 2).Value
        dOSS.add .Cells(i, 1).Value, .Cells(i, 3).Value
    Next
    End With
    
    Dim lRow%, leftIp$, cellsNum, freqNum%
    lRow = [A65536].End(xlUp).Row
    On Error Resume Next
    For i = 2 To lRow
        '如果Cells(i, 1).Value为空，则对应行不作处理，也为空
        If Cells(i, 1).Value <> "" Then
            leftIp = Left(Cells(i, 1).Value, 6)
            Cells(i, 6) = dCity(leftIp)
            Cells(i, 7) = Cells(i, 2) '名称
            Cells(i, 8) = Cells(i, 1) 'IP
            Cells(i, 9) = dOSS(leftIp)
            cellsNum = Cells(i, 4).Value
            freqNum = Cells(i, 5).Value
            Cells(i, 10) = addResult(cellsNum, freqNum)
            Cells(i, 11) = Cells(i, 4).Value
            Cells(i, 12) = Cells(i, 5).Value
        End If
    Next
    '此处妙，多重功能：删除A列空行，不正确IP，8.137站点
    Columns("F:F").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    Application.ScreenUpdating = True
    
End Sub

Function addResult(cellsNum, freqNum)
    
    If cellsNum = "" Then
        addResult = "断X"
    ElseIf cellsNum = 0 Then
        addResult = "无XX数据"
    ElseIf freqNum / cellsNum = 4 Then
        addResult = "配齐4个XX"
    Else
        addResult = "因占用XX未配齐"
    End If

End Function

Sub formatting2()
'    置中，加边框，上色
    Range("I1:J6").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    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 = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Range("I1:J1").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 5287936
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("I6:J6").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent5
        .TintAndShade = 0.599993896298105
        .PatternTintAndShade = 0
    End With
    Rows("2:6").Select
    Selection.RowHeight = 21

    Columns("I:J").Select
    Selection.ColumnWidth = 17.88

End Sub