电商运营数据分析常用宏

发表于 更新于 分类于 阅读次数 评论数

可根据注释自行调整参数

成品

表

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
Sub 二维表转一维表()
    Dim application As Object
    Dim sh As Object
    Dim rng As Range
    Dim arr() As Variant
    Dim crr() As Variant
    Dim brr() As Variant
    Dim rng2 As Range
    Dim i As Long, j As Long, j2 As Long, k As Long
    Dim rnum As Long, col As Long
    
    Set application = GetObject(, "Excel.Application")
    Set sh = application.ActiveSheet
    Set rng = application.Selection
    
    arr = rng.Value
    
    If rng.Columns.Count = 2 Then
        ' 二列数据转一列数据或一列数据转二列数据
        If IsNumeric(arr(1, 2)) Then
            ' 二列数据转一列数据
            Dim d As Object
            Set d = CreateObject("Scripting.Dictionary")
            
            For i = 1 To UBound(arr)
                If d.Exists(arr(i, 1)) Then
                    d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 2)
                Else
                    d(arr(i, 1)) = arr(i, 2)
                End If
            Next
            
            Set rng = application.InputBox("请选择结果存放区域", "提示", Type:=8)
            rng.Resize(d.Count, 1).Value = application.Transpose(d.Keys)
            rng.Offset(0, 1).Resize(d.Count, 1).Value = application.Transpose(d.Items)
        Else
            ' 一列数据转二列数据
            Dim t As String
            
            t = arr(1, 2)
            
            ReDim brr(UBound(arr) - 2, 2)
            
            For i = 2 To UBound(arr)
                brr(i - 2, 0) = arr(i, 1)
                brr(i - 2, 1) = t
                brr(i - 2, 2) = arr(i, 2)
            Next
            
            Set rng = application.InputBox("请选择结果存放区域", "提示", Type:=8)
            rng.Resize(UBound(arr) - 1, 3).Value = brr
        End If
        
        GoTo EndSub
    End If
    
    ' 二维表格数据转一维表格数据
    If IsNumeric(arr(2, 2)) Then
        Set rng2 = rng.Offset(0, 1).Resize(1, UBound(arr, 2) - 1)
    Else
        Set rng2 = application.InputBox("请选择数据对应的标题字段", "提示", Type:=8)
    End If
    
    If rng2.Row <> rng.Row Then
        MsgBox "标题行错误"
        GoTo EndSub
    End If
    
    brr = rng2.Value
    rnum = rng2.Rows.Count
    
    If rnum > 2 Then
        MsgBox "最多只能选择2行", , "提示"
        GoTo EndSub
    End If
    
    col = rng2.Column - rng.Column + 1
    
    If rnum > 1 Then
        For i = 2 To UBound(brr, 2)
            If brr(1, i) = "" Then brr(1, i) = brr(1, i - 1)
        Next
    End If
    
    ReDim Preserve crr((UBound(arr) - rnum) * UBound(brr, 2) - 1, col)
    k = -1
    
    For i = rnum + 1 To UBound(arr)
        For j = 1 To UBound(brr, 2)
            k = k + 1
            For j2 = 1 To col - 1
                crr(k, j2 - 1) = arr(i, j2)
            Next
            crr(k, col - 1) = brr(1, j)
            crr(k, col) = arr(i, col + j - 1)
        Next
    Next
    
    Set rng = application.InputBox("请选择结果存放区域", "提示", Type:=8)
    rng.Resize(UBound(crr) + 1, UBound(crr, 2) + 1).Value = crr
    
EndSub:
    Set application = Nothing
    Set sh = Nothing
    Set rng = Nothing
End Sub
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
Sub 删除包含关键词的行()
    Dim lastRow As Long
    Dim cellValue As String
    Dim keywords() As String
    Dim k As Long
    Dim i As Long
    
    '设置要删除的关键词
    keywords = Split("关键词1,关键词2", ",")
    
    '获取 A 列的最后一行
    lastRow = Cells(Rows.Count, 1).End(xlUp).Row
    
    '遍历 A 列的每个单元格
    For i = lastRow To 1 Step -1
        cellValue = Cells(i, 1).Value
        
        '检查单元格值是否包含任何一个关键词
        For k = 0 To UBound(keywords)
            If InStr(1, cellValue, keywords(k), vbTextCompare) > 0 Then
                '如果包含关键词，则删除该行
                Rows(i).Delete
                Exit For
            End If
        Next k
    Next i
End Sub
1
2
3
4
5
6
Sub 日期格式标准化()
    '将形如20231026的单元格改为2023/10/26标准日期格式
    For Each cell In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
        cell.Value = Format(DateSerial(Left(cell.Value, 4), Mid(cell.Value, 5, 2), Right(cell.Value, 2)), "YYYY/MM/DD")
    Next cell
End Sub
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
Sub 数字格式标准化()
    '<声明变量类型 Begin>
    Dim i As Long
    Dim lastCell As String
    Dim cell As Range
    '<声明变量类型 End>
    '<关闭屏幕刷新、警告框、更新链接窗口 Begin>
    application.ScreenUpdating = False
    application.DisplayAlerts = False
    application.AskToUpdateLinks = False
    '<关闭屏幕刷新、警告框、更新链接窗口 End>
    '<取消以文本形式储存的数字 Begin>
    With ActiveSheet.UsedRange
      For i = 1 To .Columns.Count '遍历每一列
        Dim maxLen As Long '定义一个变量存储最大长度
        maxLen = 0 '初始化为0
        For Each cell In .Columns(i).Cells '遍历每一列的单元格
          If Len(cell.Value) > maxLen Then '如果单元格内容长度大于最大长度
            maxLen = Len(cell.Value) '更新最大长度
          End If
        Next cell
        If maxLen <= 15 Then '判断最大长度
          .Columns(i).Value = .Columns(i).Value '取消以文本形式储存的数字
        End If
      Next i
    End With
    '<取消以文本形式储存的数字 End>
    '<自动调整行高、列宽 Begin>
    Cells.EntireColumn.AutoFit
    Cells.EntireRow.AutoFit
    '<自动调整行高、列宽 End>
    '<恢复屏幕刷新 Begin>
    application.ScreenUpdating = True
    '<恢复屏幕刷新 End>
    '<保存 Begin>
    ActiveWorkbook.Save
    '<保存 End>
    '<复制表头外全域数据 Begin>
    ActiveSheet.Range("A2:" & Cells(Rows.Count, ActiveSheet.UsedRange.Columns.Count).End(xlUp).Address).Copy
    '<复制表头外全域数据 End>
End Sub
1
2
3
4
Sub 自动调整行高·列宽()
    Cells.EntireColumn.AutoFit
    Cells.EntireRow.AutoFit
End Sub
1
2
3
4
5
6
7
8
9
10
11
12
13
14
Sub 跨列居中()
    Selection.UnMerge
    With Selection
        .HorizontalAlignment = xlCenterAcrossSelection
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
End Sub
1
2
3
4
5
6
7
8
9
10
11
12
Sub 工作表名称替换()
    Dim ws As Worksheet

    For Each ws In ActiveWorkbook.Worksheets
        ws.Name = Replace(ws.Name, "0501-0507", "19")
        ws.Name = Replace(ws.Name, "0508-0514", "20")
        ws.Name = Replace(ws.Name, "0515-0521", "21")
        ws.Name = Replace(ws.Name, "0522-0528", "22")
        ws.Name = Replace(ws.Name, "0529-0604", "23")
        ws.Name = Replace(ws.Name, "0605-0611", "24")
    Next ws
End Sub

数据透视表

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Sub 去除数据透视表字段标题前缀()
    Dim pt As PivotTable
    Dim CT As PivotField
    For Each pt In ActiveSheet.PivotTables
        For Each CT In pt.DataFields
            With CT
                If Left(.Caption, 3) = "求和项" Then .Caption = Right(.Caption, Len(.Caption) - 4) & " "
                If Left(.Caption, 3) = "计数项" Then .Caption = Right(.Caption, Len(.Caption) - 4) & " "
                If Left(.Caption, 4) = "平均值项" Then .Caption = Right(.Caption, Len(.Caption) - 5) & " "
                If Left(.Caption, 4) = "最大值项" Then .Caption = Right(.Caption, Len(.Caption) - 5) & " "
                If Left(.Caption, 4) = "最小值项" Then .Caption = Right(.Caption, Len(.Caption) - 5) & " "
                If Left(.Caption, 3) = "=乘积项" Then .Caption = Right(.Caption, Len(.Caption) - 4) & " "
            End With
        Next CT
    Next pt
End Sub
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Sub 隐藏数据透视表字段标题前缀()
    Dim pt As PivotTable
    Dim pf As PivotField
    Dim cellContent As String
    
    '遍历活动工作表上的所有数据透视表
    For Each pt In ActiveSheet.PivotTables
        '选择每个数据透视表的字段标题
        For Each pf In pt.DataFields
            pf.LabelRange.Select
            cellContent = Selection.Value
            If InStr(cellContent, ":") > 0 Then
                Dim textAfterColon As String
                textAfterColon = Trim(Mid(cellContent, InStr(cellContent, ":") + 1))
                Selection.NumberFormatLocal = "\:;;;""" & textAfterColon & """"
            End If
        Next pf
    Next pt
End Sub
1
2
3
4
5
Sub 刷新工作簿内所有数据透视表()
    Dim oWB  As Workbook
    Set oWB = Excel.ActiveWorkbook
    oWB.RefreshAll
End Sub
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
Sub 数据透视表字段添加条件格式()
    If Selection.FormatConditions.Count > 0 Then
            Dim selectedCell As Range
            Dim pt As PivotTable
            Dim ptField As PivotField
            Dim dataRange As Range
            
            Set selectedCell = ActiveCell
            Set pt = selectedCell.PivotTable
            Set ptField = pt.PivotFields(selectedCell.PivotField.Name)
            Set dataRange = ptField.dataRange
            
            dataRange.FormatConditions.Delete
        Else
            Selection.FormatConditions.AddDatabar
            Selection.FormatConditions(Selection.FormatConditions.Count).ShowValue = True
            Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
            With Selection.FormatConditions(1)
                .MinPoint.Modify newtype:=xlConditionValueAutomaticMin
                .MaxPoint.Modify newtype:=xlConditionValueAutomaticMax
            End With
            With Selection.FormatConditions(1).BarColor
                .Color = 13012579
                .TintAndShade = 0
            End With
            Selection.FormatConditions(1).BarFillType = xlDataBarFillSolid
            Selection.FormatConditions(1).Direction = xlContext
            Selection.FormatConditions(1).NegativeBarFormat.ColorType = xlDataBarColor
            Selection.FormatConditions(1).BarBorder.Type = xlDataBarBorderNone
            Selection.FormatConditions(1).AxisPosition = xlDataBarAxisAutomatic
            With Selection.FormatConditions(1).AxisColor
                .Color = 0
                .TintAndShade = 0
            End With
            With Selection.FormatConditions(1).NegativeBarFormat.Color
                .Color = 255
                .TintAndShade = 0
            End With
            Selection.FormatConditions(1).ScopeType = xlSelectionScope
            Selection.FormatConditions(1).ScopeType = xlFieldsScope
    End If
End Sub
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
Sub 修改单元格格式()
    Dim currentColumn As Range
    Dim pt As PivotTable
    Dim pf As PivotField
    Dim strFormat As String
    Dim intChoice As Integer

    intChoice = application.InputBox("请选择需要的格式：" & vbCrLf & _
        "1. 整数" & vbCrLf & _
        "2. 保留一位小数" & vbCrLf & _
        "3. 保留两位小数" & vbCrLf & _
        "4. 保留一位小数并添加万后缀" & vbCrLf & _
        "5. 保留一位小数并添加w后缀" & vbCrLf & _
        "6. 整数百分比" & vbCrLf & _
        "7. 保留一位小数的百分比" & vbCrLf & _
        "8. 保留两位小数的百分比", "格式选择", Type:=1)

    Select Case intChoice
        Case 1
            strFormat = "0"
        Case 2
            strFormat = "0.0"
        Case 3
            strFormat = "0.00"
        Case 4
            strFormat = "0\.0,""万"""
        Case 5
            strFormat = "0\.0,""w"""
        Case 6
            strFormat = "0%"
        Case 7
            strFormat = "0.0%"
        Case 8
            strFormat = "0.00%"
        Case Else
            Exit Sub
    End Select

    If Not pt Is Nothing Then
        ' 修改选中单元格所在数据透视表字段格式
        Set pf = ActiveCell.PivotField
        With pt.PivotFields(pf.Name)
            .NumberFormat = strFormat
        End With
    Else
        ' 修改选中单元格所在已使用区域∩所在列区域格式
        Set currentColumn = Selection.Cells(1).CurrentRegion
        If VarType(currentColumn.Cells(1, 1).Value) = vbString Then
            Set currentColumn = currentColumn.Offset(1).Resize(currentColumn.Rows.Count - 1)
        End If
        Intersect(currentColumn, Selection.Cells(1).EntireColumn).Select
        Selection.NumberFormat = strFormat
    End If
End Sub

图

1
2
3
4
5
6
7
8
9
10
Sub 折线统计图线条设为平滑线()
    Dim cht As ChartObject
    Dim ser As Series
    
    For Each cht In ActiveSheet.ChartObjects
        For Each ser In cht.Chart.SeriesCollection
            ser.Smooth = True
        Next ser
    Next cht
End Sub
1
2
3
4
5
6
7
8
9
10
11
12
13
Sub 折线统计图线条设为带数据标记的折线图和平滑线()
    Dim cht As ChartObject
    Dim ser As Series

    For Each cht In ActiveSheet.ChartObjects
        For Each ser In cht.Chart.SeriesCollection
            If ser.ChartType = xlLine Then
                ser.ChartType = xlLineMarkers
                ser.Smooth = True
            End If
        Next ser
    Next cht
End Sub
1
2
3
4
5
6
7
8
9
10
11
12
Sub 折线开端添加系列名称()
    Dim srs As Series
    For Each srs In ActiveChart.SeriesCollection
        srs.Points(1).Select
        Selection.ApplyDataLabels
        With Selection.DataLabel
            .Position = xlLabelPositionLeft
            .NumberFormat = "General"
            .Caption = srs.Name
        End With
    Next srs
End Sub

单元格

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Sub 提取选区公式()
    ' 需 Alt+F11-工具-引用-浏览："C:\Windows\System32\FM20.DLL"，启用 Microsoft Forms 2.0 Object Library
    ' 此宏从选区提取公式并写入剪贴板
    Dim rng As Range ' 选定范围
    Dim cell As Range ' 选定范围内每个单元格
    Dim formula As String ' 每个单元格的公式
    Dim formulas As String ' 所有单元格的连接公式
    
    Set rng = Selection ' 设置选定范围
    formulas = "" ' 初始化公式字符串
    
    ' 循环遍历选定范围内每个单元格
    For Each cell In rng
        formula = cell.formula ' 获取当前单元格公式
        If formula <> "" Then ' 如果单元格不为空
            formulas = formulas & cell.Address & ": " & formula & vbNewLine ' 连接单元格地址和公式
        End If
    Next cell
    
    ' 将公式复制到剪贴板
    Dim obj As New DataObject
    obj.SetText formulas
    obj.PutInClipboard
End Sub

组件

1
2
3
4
5
6
'<禁用文档检查器 Begin>
ActiveWorkbook.RemovePersonalInformation = False '禁止保存时弹出“请注意！文档的部分内容可能包含文档检查器无法删除的个人信息。”
'<禁用文档检查器 End>
'<保存当前工作簿 Begin>
ActiveWorkbook.Save
'<保存当前工作簿 End>
1
2
3
4
5
'<禁止屏幕刷新、警告框、更新链接窗口 Begin>
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
'<禁止屏幕刷新、警告框、更新链接窗口 End>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
'<筛选-时间顺序排列 Begin>
Cells.AutoFilter
Application.ActiveSheet.AutoFilter.Sort.SortFields.Add Key:=Range( _
    "A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    xlSortNormal
With Application.ActiveSheet.AutoFilter.Sort
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
'<筛选-时间顺序排列 End>
'<筛选-时间降序排列 Begin>
Cells.AutoFilter
Application.ActiveSheet.AutoFilter.Sort.SortFields.Add2 Key:= _
    Range("A1"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption _
    :=xlSortNormal
With Application.ActiveSheet.AutoFilter.Sort
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
'<筛选-时间降序排列 End>
1
2
3
4
5
6
7
8
9
10
11
12
'<定位A列中首个空单元格 Begin>
Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Select
'<定位A列中首个空单元格 End>
'<定位第22行中首个空单元格 Begin>
Range("XFD22").End(xlToLeft).Offset(0, 1).Select
'<定位第22行中首个空单元格 End>
'<选择E2到D列末尾单元格区域 Begin>
Range("E2:D" & [e65536].End(xlUp).Row).Select
'<选择E2到D列末尾单元格区域 End>
'<复制E2到BE列末尾单元格区域 Begin>
Range("A1:BE" & [e65536].End(xlUp).Row).Copy
'<复制E2到BE列末尾单元格区域 End>
1
2
3
4
5
6
7
8
9
10
11
12
'<删除非当前月数据 Begin>
Dim currentMonth As String
currentMonth = Format(Date, "mm")
Dim i As Long
For i = Range("D" & Rows.Count).End(xlUp).Row To 2 Step -1 '从 D 列的最后一行开始循环到 D2
    Dim month As String
    month = Mid(Cells(i, 4).Value, 6, 2) '截取 D 列当前行的月份
    If month <> currentMonth Then
      Rows(i).Delete
    End If
Next i
'<删除非当前月数据 End>
1
2
3
4
5
'<清除选中单元格公式 Begin>
For Each Cell In ActiveSheet.UsedRange
If Cell.HasFormula Then Cell.Formula = Cell.Value
Next Cell
'<清除选中单元格公式 End>
1
2
3
'<取消选中 Begin>
SendKeys"{ESC}"
'<取消选中 End>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
'<选择 F 列到 AM 列已使用行 Begin>
Range("F:AM").Resize(ActiveSheet.UsedRange.Rows.Count).Select
'<选择 F 列到 AM 列已使用行 End>
'<选择表头外 A 列到 B 列已使用行 Begin>
Dim usedRange As Range
Set usedRange = ActiveSheet.Range("A2:B" & ActiveSheet.usedRange.Rows.Count)
usedRange.Select
'<选择表头外 A 列到 B 列已使用行 End>
'<复制表头外全域数据 Begin>
With ActiveSheet
    Dim lastRow As Long
    Dim lastCol As Long
    lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column '获取最后一列列号
    .Range("A2", .Cells(lastRow, lastCol)).Copy
End With
'<复制表头外全域数据 End>
'<复制表头外全域数据 Begin>
ActiveSheet.Range("A2:" & Cells(Rows.Count, ActiveSheet.UsedRange.Columns.Count).End(xlUp).Address).Copy
'<复制表头外全域数据 End>
1
2
3
4
5
6
7
8
9
10
11
Sub 已使用单元格专题()
    With ActiveSheet
        .UsedRange.Columns("I").Value = .UsedRange.Columns("I").Value '将 I 列单元格格式设为常规格式
        .UsedRange.Columns("D").Select '选择 D 列已使用单元格
        .UsedRange.Columns("D").Offset(1).Select '选择 D 列向下偏移 1 行已使用单元格
        .UsedRange.Columns("D:E").Clear '清除 D 列、E 列已使用单元格数据
        .UsedRange.Offset(1).Clear '清除表头外所有已使用单元格数据
        .UsedRange.Copy '复制所有已使用单元格数据
    End With
    ActiveSheet.UsedRange.Columns("I").Value = ActiveSheet.UsedRange.Columns("I").Value '非 With 写法
End Sub
1
2
3
4
'<依据 1、3 列字段删除重复值 Begin>
ActiveSheet.Range("表").RemoveDuplicates Columns:=Array(1, 3), Header:= _
    xlYes
'<依据 1、3 列字段删除重复值 End>