首页 > 代码库 > 利用excel VBA进行自动化数据分析，数据汇总，网页表单自动提交等功能
利用excel VBA进行自动化数据分析，数据汇总，网页表单自动提交等功能
在制造业公司的生产管理，经营管理，采购管理，财务管理等工作中，都有大量的数据处理的任务，通过繁复的excel手工运算获取结果。通过员工培训和自我提升，掌握和使用excel数组公式和VBA自动化，能为员工节省巨大的时间和精力，提高工作附加值。同时作为公司效率化和系统化改善的一部分，为公司效益带来显著提升。以下通过一些案例，展示利用excel公式和VBA进行自动化数据分析，数据汇总，网页表单自动提交在实际场景中的典型应用。相关的文件和代码可以在github下载。
- 自动化数据分析
以下是通过VBA自动化数据分析来计算预计在手和在途库存的流程。
以下是预计在手和在途库存的代码。
1 Sub 预计在手和在途() 2 ‘ 3 ‘ 预计在手和在途 宏 4 ‘ 5 SCH_IDITEM_NO (7) 6 SCH_IDITEM_NO (11) 7 SCH_IDITEM_NO (21) 8 9 P = ActiveWorkbook.Path 10 Columns("C:C").Select 11 Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove 12 Range("C1").Select 13 ActiveCell.FormulaR1C1 = "=RC[-2]&RC[-1]" 14 Range("C1").Select 15 Selection.AutoFill Destination:=Range("C1:C138750") 16 Columns("C:C").Select 17 Selection.Copy 18 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 19 :=False, Transpose:=False 20 21 For Each cel In Range("c2:c160000") 22 If IsNumeric(cel) And cel <> "" Then 23 cel.Value = http://www.mamicode.com/Val(cel.Value) 24 End If 25 Next 26 27 Range("A1").Select 28 Range(Selection, Selection.End(xlDown)).Select 29 Range(Selection, Selection.End(xlToRight)).Select 30 Selection.Copy 31 Workbooks.Open ("C:\Users\5106002125\Desktop\企划管理\静态参考资料\套用公式\在库试算.xlsx") 32 Sheets.Add After:=Sheets(Sheets.Count) 33 Range("A1").Select 34 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 35 :=False, Transpose:=False 36 Rows("1:1").Select 37 Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove 38 39 Sheets("7").Select 40 ActiveSheet.UsedRange.Select 41 Selection.Clear 42 Sheets("11").Select 43 ActiveSheet.UsedRange.Select 44 Selection.Clear 45 Sheets("21").Select 46 ActiveSheet.UsedRange.Select 47 Selection.Clear 48 49 Set book1 = Workbooks.Open("C:\Users\5106002125\Desktop\企划管理\过期\7.csv") 50 Set book2 = Workbooks.Open("C:\Users\5106002125\Desktop\企划管理\过期\11.csv") 51 Set book3 = Workbooks.Open("C:\Users\5106002125\Desktop\企划管理\过期\21.csv") 52 53 Windows("7.csv").Activate 54 Range("A1").Select 55 Range(Selection, Selection.End(xlDown)).Select 56 Range(Selection, Selection.End(xlToRight)).Select 57 Selection.Copy 58 Windows("在库试算.xlsx").Activate 59 Sheets("7").Select 60 Range("A1").Select 61 ActiveSheet.Paste 62 63 Windows("11.csv").Activate 64 Range("A1").Select 65 Range(Selection, Selection.End(xlDown)).Select 66 Range(Selection, Selection.End(xlToRight)).Select 67 Selection.Copy 68 Windows("在库试算.xlsx").Activate 69 Sheets("11").Select 70 Range("A1").Select 71 ActiveSheet.Paste 72 73 Windows("21.csv").Activate 74 Range("A1").Select 75 Range(Selection, Selection.End(xlDown)).Select 76 Range(Selection, Selection.End(xlToRight)).Select 77 Selection.Copy 78 Windows("在库试算.xlsx").Activate 79 Sheets("21").Select 80 Range("A1").Select 81 ActiveSheet.Paste 82 83 84 For col = 20 To 41 85 86 Sheets("公式").Select 87 Range(Cells(2, col), Cells(3, col)).Select 88 Application.CutCopyMode = False 89 Selection.Copy 90 Sheets("Sheet2").Select 91 Range(Cells(2, col), Cells(3, col)).Select 92 Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _ 93 SkipBlanks:=False, Transpose:=False 94 95 Range(Cells(3, col), Cells(3, col)).Select 96 Application.CutCopyMode = False 97 Selection.AutoFill Destination:=Range(Cells(3, col), Cells(200000, col)) 98 99 Range(Cells(3, col), Cells(200000, col)).Copy 100 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 101 :=False, Transpose:=False 102 103 Next 104 105 106 Sheets("公式").Select 107 Range(Cells(1, 1), Cells(1, 41)).Select 108 Application.CutCopyMode = False 109 Selection.Copy 110 Sheets("Sheet2").Select 111 Range(Cells(1, 1), Cells(1, 41)).Select 112 Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _ 113 SkipBlanks:=False, Transpose:=False 114 115 Dim r As Integer 116 Range("a2").Select 117 Selection.End(xlDown).Select 118 r = Selection.row 119 Range(Cells(1, 1), Cells(r, 41)).Copy 120 Workbooks.Add 121 Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks _ 122 :=False, Transpose:=False 123 Application.CutCopyMode = False 124 Range("AC1:AO1").Style = "Comma" 125 126 Range("AM2:AO2").Select 127 Range("AO2").Activate 128 Range(Selection, Selection.End(xlDown)).Select 129 Sheets.Add 130 ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _ 131 "Sheet1!R2C39:R138210C41", Version:=xlPivotTableVersion14).CreatePivotTable _ 132 TableDestination:="Sheet4!R3C1", TableName:="数据透视表1", DefaultVersion:= _ 133 xlPivotTableVersion14 134 Sheets("Sheet4").Select 135 Cells(3, 1).Select 136 With ActiveSheet.PivotTables("数据透视表1").PivotFields("库位2") 137 .Orientation = xlRowField 138 .Position = 1 139 End With 140 ActiveSheet.PivotTables("数据透视表1").AddDataField ActiveSheet.PivotTables("数据透视表1" _ 141 ).PivotFields("在手"), "求和项:在手", xlSum 142 ActiveSheet.PivotTables("数据透视表1").AddDataField ActiveSheet.PivotTables("数据透视表1" _ 143 ).PivotFields("在途"), "计数项:在途", xlCount 144 With ActiveSheet.PivotTables("数据透视表1").PivotFields("计数项:在途") 145 .Caption = "求和项:在途" 146 .Function = xlSum 147 End With 148 Cells.Select 149 Selection.Style = "Comma" 150 151 ActiveWorkbook.SaveAs Filename:=P & "\在库试算结果" & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False 152 153 book1.Close savechanges:=True 154 book2.Close savechanges:=True 155 book3.Close savechanges:=True 156 157 End Sub 158 Function SCH_IDITEM_NO(n) 159 ‘ 160 ‘ SCH_IDITEM_NO 宏 161 ‘ 162 163 ‘ 164 p1 = ActiveWorkbook.Path 165 Workbooks.Open (p1 & "\" & n & ".csv") 166 Columns("C:C").Select 167 Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove 168 Range("C1").Select 169 ActiveCell.FormulaR1C1 = "=RC[-2]&RC[-1]" 170 Range("C1").Select 171 Selection.AutoFill Destination:=Range("C1:C138750") 172 Columns("C:C").Select 173 Selection.Copy 174 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 175 :=False, Transpose:=False 176 177 For Each cel In Range("c2:c160000") 178 If IsNumeric(cel) And cel <> "" Then 179 cel.Value = http://www.mamicode.com/Val(cel.Value) 180 End If 181 Next 182 183 ActiveWorkbook.SaveAs Filename:="C:\Users\5106002125\Desktop\企划管理\过期\" & ActiveWorkbook.Name, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False 184 ActiveWorkbook.Close 185 End Function
以下是通过VBA自动化计算实际在库金额的代码，比预计在手和在途库存的流程简单。
1 Sub 实际在库() 2 ‘ 3 ‘ 实际在库 宏 4 ‘ 5 6 ‘ 7 Range("A1").Select 8 Range(Selection, Selection.End(xlDown)).Select 9 Range(Selection, Selection.End(xlToRight)).Select 10 Selection.Copy 11 Workbooks.Open ("C:\Users\5106002125\Desktop\企划管理\静态参考资料\套用公式\201603库存 结果.xlsx") 12 Sheets.Add After:=Sheets(Sheets.Count) 13 Range("A1").Select 14 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 15 :=False, Transpose:=False 16 Sheets("3月底在库").Select 17 Range("Q1:Q2").Select 18 Application.CutCopyMode = False 19 Selection.Copy 20 Sheets("Sheet1").Select 21 Range("O1").Select 22 Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _ 23 SkipBlanks:=False, Transpose:=False 24 Range("O2").Select 25 Sheets("3月底在库").Select 26 Range("O1:Q2").Select 27 Application.CutCopyMode = False 28 Selection.Copy 29 Sheets("Sheet1").Select 30 Range("O1").Select 31 Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _ 32 SkipBlanks:=False, Transpose:=False 33 Range("O2:P2").Select 34 Application.CutCopyMode = False 35 Selection.AutoFill Destination:=Range("O2:P18191") 36 Range("a1").Select 37 Range(Selection, Selection.End(xlDown)).Select 38 Range(Selection, Selection.End(xlToRight)).Select 39 Selection.Copy 40 Workbooks.Add 41 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 42 :=False, Transpose:=False 43 Application.CutCopyMode = False 44 Sheets.Add 45 ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _ 46 "Sheet1!R1C1:R18191C17", Version:=xlPivotTableVersion14).CreatePivotTable _ 47 TableDestination:="Sheet4!R3C1", TableName:="数据透视表1", DefaultVersion:= _ 48 xlPivotTableVersion14 49 Sheets("Sheet4").Select 50 Cells(3, 1).Select 51 ActiveSheet.PivotTables("数据透视表1").AddDataField ActiveSheet.PivotTables("数据透视表1" _ 52 ).PivotFields("END_AMT"), "求和项:END_AMT", xlSum 53 With ActiveSheet.PivotTables("数据透视表1").PivotFields("机种") 54 .Orientation = xlRowField 55 .Position = 1 56 End With 57 58 Cells.Select 59 Selection.Style = "Comma" 60 End Sub
- 自动化数据汇总
以下是通过VBA自动化数据汇总来计算生产计划变化推移图的流程。
以下是计算生产计划变化推移图的代码。
第一次VBA计算
1 Sub Capa_MTG运算() 2 3 ‘对话框,确认已经打开Capa MTG 4 Dim Msg, Style, title, Help, Ctxt, Response, MyString 5 Msg = "当前窗口是Capa MTG?" ‘ 定义信息。 6 Style = vbYesNo + vbCritical + vbDefaultButton2 ‘ 定义按钮。 7 title = "打开Capa MTG" ‘ 定义标题。 8 Response = MsgBox(Msg, Style, title) 9 10 ‘提取最新的计划 11 12 If Response = vbYes Then ‘ 用户按下“是”。 13 For j = 1 To 6 ‘在第一到第六个工作表运行程序 14 Worksheets(j).Select ‘选定工作表 15 [a1:dd300].UnMerge ‘所有单元格取消合并 16 Rows("6:6").Select 17 Selection.AutoFilter ‘自动筛选 18 Range("C2:C124").Select 19 Selection.Copy 20 Range("F8:f130").Select 21 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 22 :=False, Transpose:=False ‘复制最新计划的机种名,到计划台数的这一列 23 Next 24 End If 25 26 ‘OPT计划复制到BPJ 27 28 Sheets("opt").Range("C2:Dd150").Copy 29 Sheets("bpj").Range("c132").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 30 :=False, Transpose:=False 31 Sheets("bpj").Range("g127") = "0" 32 Sheets("bpj").Range("f65") = "LEOPARD" 33 For j = 1 To 6 ‘在第一到第六个工作表运行程序 34 Worksheets(j).Select ‘选定工作表 35 36 ‘自动筛选,获得最新计划原始数据 37 38 Dim i As Integer 39 For i = 8 To 63 40 If Range("f" & i) = 0 Then 41 Range("g" & i) = "0" 42 End If 43 Next 44 For i = 66 To 300 45 If Range("f" & i) = 0 Then 46 Range("g" & i) = "0" 47 End If 48 Next 49 Range("bb65:dc65") = "0" 50 ActiveSheet.Range("$A$6:$DD$300").AutoFilter Field:=7, Criteria1:="①" 51 Next 52 53 ‘保存修改后的文件到本地 54 55 ActiveWorkbook.SaveAs Filename:= _ 56 "C:\Users\5106002125\Desktop\企划管理\过期\Capa MTG16.xlsx", FileFormat:= _ 57 xlOpenXMLWorkbook, CreateBackup:=False 58 End Sub
第二次VBA计算
1 Sub PSG生产计划变化() 2 3 Application.ScreenUpdating = False 4 5 Dim wkbname As Integer 6 7 ‘在每个工作表运行程序 8 9 For wkbname = 1 To 5 10 Worksheets(wkbname).Select 11 Pro_change (wkbname) 12 Next 13 14 End Sub 15 Function Pro_change(wkbname As Integer) 16 17 ‘指定复制的行数 18 19 Dim row As Integer 20 If wkbname = 1 Then 21 row = 23 22 ElseIf wkbname = 2 Then 23 row = 4 24 ElseIf wkbname = 3 Then 25 row = 2 26 Else: row = 1 27 End If 28 29 ‘复制前一周的计划数量 30 31 Range("a3").Select 32 Selection.End(xlDown).Offset(1 - row, 0).Resize(row, 250).Select 33 Selection.Copy 34 Selection.Offset(row, 0).Activate 35 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 36 :=False, Transpose:=False 37 38 ‘WK赋值 39 40 Dim wk As Integer 41 wk = Application.WeekNum(Now() - 11) 42 Range("b3").Select 43 Selection.End(xlDown).Offset(1 - row, -1).Resize(row, 1).Value =http://www.mamicode.com/ wk 44 45 ‘复制最新生产计划 46 47 Range("c1").Select 48 Selection.Copy 49 Selection.End(xlDown).Offset(1 - row, 20).Resize(row, 200).Select 50 ActiveSheet.Paste 51 Application.CutCopyMode = False 52 53 ‘复制前一周的计划格式 54 55 Range("a3").Select 56 Selection.End(xlDown).Offset(1 - row * 2, 0).Resize(row, 250).Select 57 Selection.Copy 58 Selection.Offset(row, 0).Activate 59 Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks _ 60 :=False, Transpose:=False 61 62 ‘更新最新计划的单元格格式 63 64 Range("a3").Select 65 Selection.End(xlDown).Offset(1 - row, wk - 1).Resize(row, 2).Select 66 Selection.Copy 67 Selection.Offset(0, 2).Activate 68 Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks _ 69 :=False, Transpose:=False 70 71 ‘保存新的生产计划区域为数值 72 73 Range("c1").Select 74 Selection.End(xlDown).Offset(1 - row, 20).Resize(row, 250).Select 75 Selection.Copy 76 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 77 :=False, Transpose:=False 78 79 End Function
- 自动提交网页表单
以下是通过VBA自动提交网页表单来提交未着发票信息的流程。
以下是自动化提交未着发票信息的工作表界面，其中左边三列由公式自动生成结果。
以下是自动化提交未着发票信息的代码。
1 Sub 手动未着() 2 3 ‘共有多少张发票 4 Dim InvoLength As Integer 5 InvoLength = Cells(5, 4).Value ‘列表共几张发票 6 7 Dim ie As Object 8 Set ie = CreateObject("InternetExplorer.application") 9 With ie 10 For i = 1 To InvoLength 11 Cells(5, 1) = i ‘第几张发票 12 j = Cells(5, 2) ‘这张发票在第几列开始 13 manual_invo j, ie ‘打开网页填写信息 14 Next 15 End With 16 17 ‘Err_Handle: 18 ‘ MsgBox ("请重新填写信息后提交") 19 End Sub 20 Function manual_invo(j, ie) 21 Dim row_base, ItemLength_ttl As Integer 22 Dim SLIP_NO, VENDOR_CD, Amt As String 23 row_base = 8 ‘数据开始的列数 - 1 24 ItemLength_ttl = Cells(5, 3) ‘当前发票共有多少订单 25 SLIP_NO = Cells(j + row_base, 4) ‘发票号 26 VENDOR_CD = Cells(j + row_base, 5) ‘供应商 27 28 With ie 29 .navigate "https://ssv21.imapsv2.sony.co.jp/iak100/main/Invg0500?ActionType=GoFirst" 30 .Visible = True 31 Do Until .readyState = 4 32 Loop 33 34 ‘填写发票和供应商，点击搜索，等待页面加载 35 .document.getElementById("VENDOR_CD:Upper").Value =http://www.mamicode.com/ VENDOR_CD 36 .document.getElementById("SLIP_NO:Upper").Value =http://www.mamicode.com/ SLIP_NO 37 .document.getElementById("SERACH_BTN").Click 38 Do Until .readyState = 4 And .Busy = False 39 DoEvents 40 Loop 41 42 ‘发票BL时间，货币，保课税，点击“GO”，等待页面加载 43 .document.getElementById("SLIP_DATE:Date").Value = http://www.mamicode.com/Cells(j + row_base, 6) 44 .document.getElementById("SLIP_CUR:Upper").Value = http://www.mamicode.com/Cells(j + row_base, 7) 45 .document.getElementById("TRADE_TYPE_LIST").Value = http://www.mamicode.com/Cells(j + row_base, 8) 46 .document.getElementById("GO_BTN").Click 47 Do Until .readyState = 4 And .Busy = False 48 DoEvents 49 Loop 50 51 ‘录入发票中每一条订单 52 For k = 1 To ItemLength_ttl 53 fill_invo_item k, j, row_base, ie 54 Next 55 56 ‘录入AMT 57 .document.getElementById("INVOICE_AMT").Value = http://www.mamicode.com/Cells(j + row_base, 11) 58 59 ‘最后点击执行按钮 60 .document.getElementById("BTN_EXECUTE").Click 61 Do Until .readyState = 4 And .Busy = False 62 DoEvents 63 Loop 64 65 ‘等待1秒 66 Application.Wait (Now + TimeValue("0:00:01")) 67 68 End With 69 End Function 70 Function fill_invo_item(k, j, row_base, ie) 71 With ie 72 73 ‘点击ADD_PO，等待页面加载 74 .document.getElementById("BTN_ADDPO").Click 75 Do Until .readyState = 4 And .Busy = False 76 DoEvents 77 Loop 78 79 ‘填写PO，点击“GO”,等待页面加载 80 .document.getElementById("ORDER_NO:Upper").Value = http://www.mamicode.com/Cells(j + row_base, 9).Offset(k - 1, 0) 81 .document.getElementById("GO_BTN").Click 82 Do Until .readyState = 4 And .Busy = False 83 DoEvents 84 Loop 85 86 ‘不填写其他信息再次点击“GO”,等待页面加载 87 ‘.document.getElementById("INVG0500_LIST(" & k - 1 & "/INVOICE_QTY_NEW").Value = http://www.mamicode.com/Cells(j + row_base, 10).Offset(k - 1, 0) 88 ‘.document.getElementById("INVG0500_LIST(" & k - 1 & "/UNIT_PRICE").Value = http://www.mamicode.com/Cells(j + row_base, 13).Offset(k - 1, 0) 89 .document.getElementById("GO_BTN").Click 90 Do Until .readyState = 4 And .Busy = False 91 DoEvents 92 Loop 93 94 ‘填写后在EXCEL这一列打勾 95 Cells(j + row_base, 12).Offset(k - 1, 0).Value = http://www.mamicode.com/"√" 96 97 End With 98 End Function
- VBA自动化创建调查表
以下是自动化创建PUSH OUT调查表的代码。
1 Sub 创建PUSH_OUT_LIST() 2 ‘ 3 ‘ 创建PUSH_OUT_LIST 宏 4 a = Val(InputBox("输入1是每月，输入2是季度", "选项", 1)) 5 If a = 1 Then 6 b = "每月" 7 ElseIf a = 2 Then 8 b = "季度" 9 End If 10 ActiveWorkbook.SaveAs Filename:= _ 11 "C:\Users\5106002125\Desktop\PUSH_OUT原始数据" & Format(Date, "yyyymmdd") & Second(Now) & ".xlsx", FileFormat:= _ 12 xlOpenXMLWorkbook, CreateBackup:=False 13 Range("A1").Select 14 Range(Selection, Selection.End(xlDown)).Select 15 Range(Selection, Selection.End(xlToRight)).Select 16 Selection.Copy 17 Workbooks.Open ("C:\Users\5106002125\Desktop\企划管理\静态参考资料\套用公式\PUSH OUT 算法 " & b & "推进.xlsx") 18 Sheets.Add After:=Sheets(Sheets.Count) 19 Range("A1").Select 20 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 21 :=False, Transpose:=False 22 Sheets("公式").Select 23 Range("N1:Y2").Select 24 Application.CutCopyMode = False 25 Selection.Copy 26 Sheets("Sheet1").Select 27 Range("N1").Select 28 Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _ 29 SkipBlanks:=False, Transpose:=False 30 Range("N2:Y2").Select 31 Application.CutCopyMode = False 32 Selection.AutoFill Destination:=Range("N2:Y181910") 33 34 Range("a1").Select 35 Range(Selection, Selection.End(xlDown)).Select 36 Range(Selection, Selection.End(xlToRight)).Select 37 Selection.Copy 38 Workbooks.Add 39 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 40 :=False, Transpose:=False 41 Application.CutCopyMode = False 42 43 44 45 Columns("h:h").Select 46 Selection.Cut 47 Columns("u:u").Select 48 Selection.Insert Shift:=xlToRight 49 50 Columns("v:v").Select 51 Selection.Cut 52 Columns("e:e").Select 53 Selection.Insert Shift:=xlToRight 54 55 Columns("w:w").Select 56 Selection.Cut 57 Columns("c:c").Select 58 Selection.Insert Shift:=xlToRight 59 60 [Z1] = "PUSH OUT结果" 61 [AA1] = "COMMENT" 62 63 Columns("Y:Y").Select 64 Selection.Delete Shift:=xlToLeft 65 ActiveWorkbook.SaveAs Filename:= _ 66 "C:\Users\5106002125\Desktop\PUSH_OUT" & Format(Date, "yyyymmdd") & Second(Now) & ".xlsx", FileFormat:= _ 67 xlOpenXMLWorkbook, CreateBackup:=False 68 69 Windows("PUSH OUT 算法 " & b & "推进.xlsx").Activate 70 Sheets("Sheet1").Select 71 ActiveWindow.SelectedSheets.Delete 72 73 Set sh1 = Workbooks("PUSH OUT 算法 " & b & "推进") 74 sh1.Close 75 76 Columns("U:U").Select 77 Selection.Delete Shift:=xlToLeft 78 Columns("O:S").Select 79 Range("S1").Activate 80 Selection.Delete Shift:=xlToLeft 81 Range("A1:T1").Select 82 Range("T1").Activate 83 With Selection.Interior 84 .Pattern = xlSolid 85 .PatternColorIndex = xlAutomatic 86 .ThemeColor = xlThemeColorAccent6 87 .TintAndShade = 0.399975585192419 88 .PatternTintAndShade = 0 89 End With 90 91 Range("A2").Select 92 Range(Selection, Selection.End(xlDown)).Select 93 Range(Selection, Selection.End(xlToRight)).Select 94 Selection.Borders(xlDiagonalDown).LineStyle = xlNone 95 Selection.Borders(xlDiagonalUp).LineStyle = xlNone 96 With Selection.Borders(xlEdgeLeft) 97 .LineStyle = xlContinuous 98 .ColorIndex = xlAutomatic 99 .TintAndShade = 0 100 .Weight = xlHairline 101 End With 102 With Selection.Borders(xlEdgeTop) 103 .LineStyle = xlContinuous 104 .ColorIndex = xlAutomatic 105 .TintAndShade = 0 106 .Weight = xlHairline 107 End With 108 With Selection.Borders(xlEdgeBottom) 109 .LineStyle = xlContinuous 110 .ColorIndex = xlAutomatic 111 .TintAndShade = 0 112 .Weight = xlHairline 113 End With 114 With Selection.Borders(xlEdgeRight) 115 .LineStyle = xlContinuous 116 .ColorIndex = xlAutomatic 117 .TintAndShade = 0 118 .Weight = xlHairline 119 End With 120 With Selection.Borders(xlInsideVertical) 121 .LineStyle = xlContinuous 122 .ColorIndex = xlAutomatic 123 .TintAndShade = 0 124 .Weight = xlHairline 125 End With 126 With Selection.Borders(xlInsideHorizontal) 127 .LineStyle = xlContinuous 128 .ColorIndex = xlAutomatic 129 .TintAndShade = 0 130 .Weight = xlHairline 131 End With 132 Columns("S:T").Select 133 Selection.Borders(xlDiagonalDown).LineStyle = xlNone 134 Selection.Borders(xlDiagonalUp).LineStyle = xlNone 135 With Selection.Borders(xlEdgeLeft) 136 .LineStyle = xlContinuous 137 .ColorIndex = 0 138 .TintAndShade = 0 139 .Weight = xlMedium 140 End With 141 With Selection.Borders(xlEdgeTop) 142 .LineStyle = xlContinuous 143 .ColorIndex = 0 144 .TintAndShade = 0 145 .Weight = xlMedium 146 End With 147 With Selection.Borders(xlEdgeBottom) 148 .LineStyle = xlContinuous 149 .ColorIndex = 0 150 .TintAndShade = 0 151 .Weight = xlMedium 152 End With 153 With Selection.Borders(xlEdgeRight) 154 .LineStyle = xlContinuous 155 .ColorIndex = 0 156 .TintAndShade = 0 157 .Weight = xlMedium 158 End With 159 Selection.Borders(xlInsideVertical).LineStyle = xlNone 160 Selection.Borders(xlInsideHorizontal).LineStyle = xlNone 161 Rows("2:2").Select 162 Range("D2").Activate 163 With ActiveWindow 164 .SplitColumn = 0 165 .SplitRow = 1 166 End With 167 ActiveWindow.FreezePanes = True 168 Rows("1:1").Select 169 Range("D1").Activate 170 Selection.AutoFilter 171 ActiveSheet.Range("$A$1:$Z$26903").AutoFilter Field:=15, Criteria1:="=0", _ 172 Operator:=xlOr, Criteria2:="=#N/A" 173 Rows("2:2").Select 174 Range(Selection, Selection.End(xlDown)).Select 175 Selection.Delete Shift:=xlUp 176 Selection.AutoFilter 177 Rows("1:1").Select 178 Selection.AutoFilter 179 Columns("D:E").EntireColumn.AutoFit 180 Columns("U:AL").Select 181 Selection.Delete Shift:=xlToLeft 182 Rows("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove 183 Range("O1").FormulaR1C1 = "=SUBTOTAL(9,R[2]C:R[2999]C)" 184 Range("O1").Select 185 Selection.Style = "Comma" 186 Range("S1:t1") = "担当答复" 187 Range("u1:v1") = "企划填写" 188 Range("Q2").Copy 189 Range("U2:v2").Select 190 Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ 191 SkipBlanks:=False, Transpose:=False 192 Application.CutCopyMode = False 193 Range("U2") = "依赖日期" 194 Range("V2") = "备注(新增/变更)" 195 Range("O1,S1,T1,V1,U1").Select 196 Range("U1").Activate 197 With Selection.Interior 198 .Pattern = xlSolid 199 .PatternColorIndex = xlAutomatic 200 .Color = 49407 201 .TintAndShade = 0 202 .PatternTintAndShade = 0 203 End With 204 With Selection.Font 205 .ThemeColor = xlThemeColorDark1 206 .TintAndShade = 0 207 End With 208 Columns("K:K").Select 209 Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove 210 Range("K2") = "NEW_DUE_DATE(上周)" 211 Range("L2") = "NEW_DUE_DATE(本周)" 212 Sheets("Sheet2").Select 213 ActiveWindow.SelectedSheets.Delete 214 Sheets("Sheet3").Select 215 ActiveWindow.SelectedSheets.Delete 216 Sheets.Add 217 218 ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _ 219 "Sheet1!R2C10:R1048576C19", Version:=xlPivotTableVersion14).CreatePivotTable _ 220 TableDestination:="Sheet4!R3C1", TableName:="数据透视表1", DefaultVersion:= _ 221 xlPivotTableVersion14 222 Sheets("Sheet4").Select 223 Cells(3, 1).Select 224 ActiveSheet.PivotTables("数据透视表1").AddDataField ActiveSheet.PivotTables("数据透视表1" _ 225 ).PivotFields("AMT"), "计数项:AMT", xlCount 226 With ActiveSheet.PivotTables("数据透视表1").PivotFields("LOCATION") 227 .Orientation = xlRowField 228 .Position = 1 229 End With 230 With ActiveSheet.PivotTables("数据透视表1").PivotFields("ALRAM") 231 .Orientation = xlColumnField 232 .Position = 1 233 End With 234 With ActiveSheet.PivotTables("数据透视表1").PivotFields("计数项:AMT") 235 .Caption = "求和项:AMT" 236 .Function = xlSum 237 End With 238 Cells.Select 239 Selection.Style = "Comma" 240 Cells.EntireColumn.AutoFit 241 242 End Sub
- 其他
1 Sub 调查汇总() 2 3 ‘Application.ScreenUpdating = False 4 Dim book1 As Workbook 5 Dim book2 As Workbook 6 path1 = ActiveWorkbook.Path 7 Set book1 = ActiveWorkbook 8 Workbooks.Add 9 Set book2 = ActiveWorkbook 10 book1.Activate 11 For wkbname = 1 To Worksheets.Count 12 Worksheets(wkbname).Select 13 copy_visible book1, book2 14 Next 15 book2.SaveAs Filename:=path1 & "\调查结果汇总" & Format(Date, "yyyymmdd") & Second(Now()) & ".xlsx", _ 16 FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False 17 End Sub 18 19 Function copy_visible(book1, book2) 20 Range("A2").Select 21 Range(Selection, Selection.End(xlDown)).Select 22 Range(Selection, Selection.End(xlToRight)).Select 23 Selection.Copy 24 book2.Activate 25 Range("A500000").Select 26 Range(Selection, Selection.End(xlUp)).Offset(1, 0).Select 27 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 28 :=False, Transpose:=False 29 Application.CutCopyMode = False 30 book1.Activate 31 End Function
1 Sub Sheet到Book() 2 ‘ 3 ‘ Sheet到Book 4 ‘ 5 path1 = ActiveWorkbook.Path 6 book1 = ActiveWorkbook.Name 7 ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Copy 8 Workbooks.Add 9 ActiveSheet.Paste 10 ActiveWorkbook.SaveAs Filename:=path1 & "\" & Left(book1, Len(book1) - 5) & Format(Date, "yyyymmdd") & Second(Now()) & ".xlsx", _ 11 FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False 12 ‘ 13 End Sub
1 Sub 清理工作表() 2 ‘ 3 ‘ 清理工作表 宏 4 ‘ 5 6 ‘ 7 Rows("1:1").Select 8 Range(Selection, Selection.End(xlDown)).Select 9 Range(Selection, Selection.End(xlToRight)).Select 10 Selection.Copy 11 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 12 :=False, Transpose:=False 13 ActiveWindow.LargeScroll ToRight:=-1 14 Rows("1:1").Select 15 Selection.End(xlDown).Offset(1, 0).Select 16 Range(Selection, Selection.End(xlToRight)).Select 17 Range(Selection, Selection.End(xlDown)).Select 18 Selection.Delete Shift:=xlUp 19 Rows("1:1").Select 20 Selection.End(xlToRight).Offset(0, 1).Select 21 Range(Selection, Selection.End(xlToRight)).Select 22 Range(Selection, Selection.End(xlDown)).Select 23 Selection.Delete Shift:=xlToLeft 24 25 End Sub
1 Sub 删除重复() 2 ‘ 3 ‘ 宏3 宏 4 ‘ 5 ‘ 6 Application.CutCopyMode = False 7 Selection.Copy 8 Sheets.Add After:=Sheets(Sheets.Count) 9 Columns("A:A").Select 10 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 11 :=False, Transpose:=False 12 Application.CutCopyMode = False 13 ActiveSheet.Range("$A$1:$A$100000").RemoveDuplicates Columns:=1, Header:=xlNo 14 End Sub
利用excel VBA进行自动化数据分析，数据汇总，网页表单自动提交等功能
声明：以上内容来自用户投稿及互联网公开渠道收集整理发布，本网站不拥有所有权，未作人工编辑处理，也不承担相关法律责任，若内容有误或涉及侵权可进行投诉： 投诉/举报 工作人员会在5个工作日内联系你，一经查实，本站将立刻删除涉嫌侵权内容。