利用excel VBA进行自动化数据分析，数据汇总，网页表单自动提交等功能

利用excel VBA进行自动化数据分析，数据汇总，网页表单自动提交等功能

　　在制造业公司的生产管理，经营管理，采购管理，财务管理等工作中，都有大量的数据处理的任务，通过繁复的excel手工运算获取结果。通过员工培训和自我提升，掌握和使用excel数组公式和VBA自动化，能为员工节省巨大的时间和精力，提高工作附加值。同时作为公司效率化和系统化改善的一部分，为公司效益带来显著提升。以下通过一些案例，展示利用excel公式和VBA进行自动化数据分析，数据汇总，网页表单自动提交在实际场景中的典型应用。相关的文件和代码可以在github下载。

• 自动化数据分析

　　以下是通过VBA自动化数据分析来计算预计在手和在途库存的流程。

　　以下是预计在手和在途库存的代码。

Sub 预计在手和在途()

'

' 预计在手和在途 宏

'

SCH_IDITEM_NO (7)

SCH_IDITEM_NO (11)

SCH_IDITEM_NO (21)

P = ActiveWorkbook.Path

Columns("C:C").Select

Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

Range("C1").Select

ActiveCell.FormulaR1C1 = "=RC[-2]&RC[-1]"

Range("C1").Select

Selection.AutoFill Destination:=Range("C1:C138750")

Columns("C:C").Select

Selection.Copy

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

For Each cel In Range("c2:c160000")

If IsNumeric(cel) And cel <> "" Then

cel.Value = Val(cel.Value)

End If

Next

Range("A1").Select

Range(Selection, Selection.End(xlDown)).Select

Range(Selection, Selection.End(xlToRight)).Select

Selection.Copy

Workbooks.Open ("C:\Users\5106002125\Desktop\企划管理\静态参考资料\套用公式\在库试算.xlsx")

Sheets.Add After:=Sheets(Sheets.Count)

Range("A1").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

Rows("1:1").Select

Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

Sheets("7").Select

ActiveSheet.UsedRange.Select

Selection.Clear

Sheets("11").Select

ActiveSheet.UsedRange.Select

Selection.Clear

Sheets("21").Select

ActiveSheet.UsedRange.Select

Selection.Clear

Set book1 = Workbooks.Open("C:\Users\5106002125\Desktop\企划管理\过期\7.csv")

Set book2 = Workbooks.Open("C:\Users\5106002125\Desktop\企划管理\过期\11.csv")

Set book3 = Workbooks.Open("C:\Users\5106002125\Desktop\企划管理\过期\21.csv")

Windows("7.csv").Activate

Range("A1").Select

Range(Selection, Selection.End(xlDown)).Select

Range(Selection, Selection.End(xlToRight)).Select

Selection.Copy

Windows("在库试算.xlsx").Activate

Sheets("7").Select

Range("A1").Select

ActiveSheet.Paste

Windows("11.csv").Activate

Range("A1").Select

Range(Selection, Selection.End(xlDown)).Select

Range(Selection, Selection.End(xlToRight)).Select

Selection.Copy

Windows("在库试算.xlsx").Activate

Sheets("11").Select

Range("A1").Select

ActiveSheet.Paste

Windows("21.csv").Activate

Range("A1").Select

Range(Selection, Selection.End(xlDown)).Select

Range(Selection, Selection.End(xlToRight)).Select

Selection.Copy

Windows("在库试算.xlsx").Activate

Sheets("21").Select

Range("A1").Select

ActiveSheet.Paste

For col = 20 To 41

Sheets("公式").Select

Range(Cells(2, col), Cells(3, col)).Select

Application.CutCopyMode = False

Selection.Copy

Sheets("Sheet2").Select

Range(Cells(2, col), Cells(3, col)).Select

Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _

SkipBlanks:=False, Transpose:=False

Range(Cells(3, col), Cells(3, col)).Select

Application.CutCopyMode = False

Selection.AutoFill Destination:=Range(Cells(3, col), Cells(200000, col))

Range(Cells(3, col), Cells(200000, col)).Copy

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

Next

Sheets("公式").Select

Range(Cells(1, 1), Cells(1, 41)).Select

Application.CutCopyMode = False

Selection.Copy

Sheets("Sheet2").Select

Range(Cells(1, 1), Cells(1, 41)).Select

Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _

SkipBlanks:=False, Transpose:=False

Dim r As Integer

Range("a2").Select

Selection.End(xlDown).Select

r = Selection.row

Range(Cells(1, 1), Cells(r, 41)).Copy

Workbooks.Add

Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

Application.CutCopyMode = False

Range("AC1:AO1").Style = "Comma"

Range("AM2:AO2").Select

Range("AO2").Activate

Range(Selection, Selection.End(xlDown)).Select

Sheets.Add

ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _

"Sheet1!R2C39:R138210C41", Version:=xlPivotTableVersion14).CreatePivotTable _

TableDestination:="Sheet4!R3C1", TableName:="数据透视表1", DefaultVersion:= _

xlPivotTableVersion14

Sheets("Sheet4").Select

Cells(3, 1).Select

With ActiveSheet.PivotTables("数据透视表1").PivotFields("库位2")

.Orientation = xlRowField

.Position = 1

End With

ActiveSheet.PivotTables("数据透视表1").AddDataField ActiveSheet.PivotTables("数据透视表1" _

).PivotFields("在手"), "求和项:在手", xlSum

ActiveSheet.PivotTables("数据透视表1").AddDataField ActiveSheet.PivotTables("数据透视表1" _

).PivotFields("在途"), "计数项:在途", xlCount

With ActiveSheet.PivotTables("数据透视表1").PivotFields("计数项:在途")

.Caption = "求和项:在途"

.Function = xlSum

End With

Cells.Select

Selection.Style = "Comma"

ActiveWorkbook.SaveAs Filename:=P & "\在库试算结果" & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

book1.Close savechanges:=True

book2.Close savechanges:=True

book3.Close savechanges:=True

End Sub

Function SCH_IDITEM_NO(n)

'

' SCH_IDITEM_NO 宏

'

'

p1 = ActiveWorkbook.Path

Workbooks.Open (p1 & "\" & n & ".csv")

Columns("C:C").Select

Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

Range("C1").Select

ActiveCell.FormulaR1C1 = "=RC[-2]&RC[-1]"

Range("C1").Select

Selection.AutoFill Destination:=Range("C1:C138750")

Columns("C:C").Select

Selection.Copy

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

For Each cel In Range("c2:c160000")

If IsNumeric(cel) And cel <> "" Then

cel.Value = Val(cel.Value)

End If

Next

ActiveWorkbook.SaveAs Filename:="C:\Users\5106002125\Desktop\企划管理\过期\" & ActiveWorkbook.Name, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

ActiveWorkbook.Close

End Function

以下是通过VBA自动化计算实际在库金额的代码，比预计在手和在途库存的流程简单。

Sub 实际在库()

'

' 实际在库 宏

'

'

Range("A1").Select

Range(Selection, Selection.End(xlDown)).Select

Range(Selection, Selection.End(xlToRight)).Select

Selection.Copy

Workbooks.Open ("C:\Users\5106002125\Desktop\企划管理\静态参考资料\套用公式\201603库存 结果.xlsx")

Sheets.Add After:=Sheets(Sheets.Count)

Range("A1").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

Sheets("3月底在库").Select

Range("Q1:Q2").Select

Application.CutCopyMode = False

Selection.Copy

Sheets("Sheet1").Select

Range("O1").Select

Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _

SkipBlanks:=False, Transpose:=False

Range("O2").Select

Sheets("3月底在库").Select

Range("O1:Q2").Select

Application.CutCopyMode = False

Selection.Copy

Sheets("Sheet1").Select

Range("O1").Select

Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _

SkipBlanks:=False, Transpose:=False

Range("O2:P2").Select

Application.CutCopyMode = False

Selection.AutoFill Destination:=Range("O2:P18191")

Range("a1").Select

Range(Selection, Selection.End(xlDown)).Select

Range(Selection, Selection.End(xlToRight)).Select

Selection.Copy

Workbooks.Add

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

Application.CutCopyMode = False

Sheets.Add

ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _

"Sheet1!R1C1:R18191C17", Version:=xlPivotTableVersion14).CreatePivotTable _

TableDestination:="Sheet4!R3C1", TableName:="数据透视表1", DefaultVersion:= _

xlPivotTableVersion14

Sheets("Sheet4").Select

Cells(3, 1).Select

ActiveSheet.PivotTables("数据透视表1").AddDataField ActiveSheet.PivotTables("数据透视表1" _

).PivotFields("END_AMT"), "求和项:END_AMT", xlSum

With ActiveSheet.PivotTables("数据透视表1").PivotFields("机种")

.Orientation = xlRowField

.Position = 1

End With

Cells.Select

Selection.Style = "Comma"

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 = 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自动提交网页表单来提交未着发票信息的流程。

　　以下是自动化提交未着发票信息的工作表界面，其中左边三列由公式自动生成结果。

　　以下是自动化提交未着发票信息的代码。

Sub 手动未着()

'共有多少张发票

Dim InvoLength As Integer

InvoLength = Cells(5, 4).Value  '列表共几张发票

Dim ie As Object

Set ie = CreateObject("InternetExplorer.application")

With ie

For i = 1 To InvoLength

Cells(5, 1) = i         '第几张发票

j = Cells(5, 2)         '这张发票在第几列开始

manual_invo j, ie       '打开网页填写信息

Next

End With

'Err_Handle:

'        MsgBox ("请重新填写信息后提交")

End Sub

Function manual_invo(j, ie)

Dim row_base, ItemLength_ttl As Integer

Dim SLIP_NO, VENDOR_CD, Amt As String

row_base = 8                        '数据开始的列数 - 1

ItemLength_ttl = Cells(5, 3)        '当前发票共有多少订单

SLIP_NO = Cells(j + row_base, 4)    '发票号

VENDOR_CD = Cells(j + row_base, 5)  '供应商

With ie

.navigate "https://ssv21.imapsv2.sony.co.jp/iak100/main/Invg0500?ActionType=GoFirst"

.Visible = True

Do Until .readyState = 4

Loop

'填写发票和供应商，点击搜索，等待页面加载

.document.getElementById("VENDOR_CD:Upper").Value = VENDOR_CD

.document.getElementById("SLIP_NO:Upper").Value = SLIP_NO

.document.getElementById("SERACH_BTN").Click

Do Until .readyState = 4 And .Busy = False

DoEvents

Loop

'发票BL时间，货币，保课税，点击“GO”，等待页面加载

.document.getElementById("SLIP_DATE:Date").Value = Cells(j + row_base, 6)

.document.getElementById("SLIP_CUR:Upper").Value = Cells(j + row_base, 7)

.document.getElementById("TRADE_TYPE_LIST").Value = Cells(j + row_base, 8)

.document.getElementById("GO_BTN").Click

Do Until .readyState = 4 And .Busy = False

DoEvents

Loop

'录入发票中每一条订单

For k = 1 To ItemLength_ttl

fill_invo_item k, j, row_base, ie

Next

'录入AMT

.document.getElementById("INVOICE_AMT").Value = Cells(j + row_base, 11)

'最后点击执行按钮

.document.getElementById("BTN_EXECUTE").Click

Do Until .readyState = 4 And .Busy = False

DoEvents

Loop

'等待1秒

Application.Wait (Now + TimeValue("0:00:01"))

End With

End Function

Function fill_invo_item(k, j, row_base, ie)

With ie

'点击ADD_PO，等待页面加载

.document.getElementById("BTN_ADDPO").Click

Do Until .readyState = 4 And .Busy = False

DoEvents

Loop

'填写PO，点击“GO”,等待页面加载

.document.getElementById("ORDER_NO:Upper").Value = Cells(j + row_base, 9).Offset(k - 1, 0)

.document.getElementById("GO_BTN").Click

Do Until .readyState = 4 And .Busy = False

DoEvents

Loop

'不填写其他信息再次点击“GO”,等待页面加载

'.document.getElementById("INVG0500_LIST(" & k - 1 & "/INVOICE_QTY_NEW").Value = Cells(j + row_base, 10).Offset(k - 1, 0)

'.document.getElementById("INVG0500_LIST(" & k - 1 & "/UNIT_PRICE").Value = Cells(j + row_base, 13).Offset(k - 1, 0)

.document.getElementById("GO_BTN").Click

Do Until .readyState = 4 And .Busy = False

DoEvents

Loop

'填写后在EXCEL这一列打勾

Cells(j + row_base, 12).Offset(k - 1, 0).Value = "√"

End With

End Function

• VBA自动化创建调查表

　　以下是自动化创建PUSH OUT调查表的代码。　

Sub 创建PUSH_OUT_LIST()

'

' 创建PUSH_OUT_LIST 宏

a = Val(InputBox("输入1是每月，输入2是季度", "选项", 1))

If a = 1 Then

b = "每月"

ElseIf a = 2 Then

b = "季度"

End If

ActiveWorkbook.SaveAs Filename:= _

"C:\Users\5106002125\Desktop\PUSH_OUT原始数据" & Format(Date, "yyyymmdd") & Second(Now) & ".xlsx", FileFormat:= _

xlOpenXMLWorkbook, CreateBackup:=False

Range("A1").Select

Range(Selection, Selection.End(xlDown)).Select

Range(Selection, Selection.End(xlToRight)).Select

Selection.Copy

Workbooks.Open ("C:\Users\5106002125\Desktop\企划管理\静态参考资料\套用公式\PUSH OUT 算法 " & b & "推进.xlsx")

Sheets.Add After:=Sheets(Sheets.Count)

Range("A1").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

Sheets("公式").Select

Range("N1:Y2").Select

Application.CutCopyMode = False

Selection.Copy

Sheets("Sheet1").Select

Range("N1").Select

Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _

SkipBlanks:=False, Transpose:=False

Range("N2:Y2").Select

Application.CutCopyMode = False

Selection.AutoFill Destination:=Range("N2:Y181910")

Range("a1").Select

Range(Selection, Selection.End(xlDown)).Select

Range(Selection, Selection.End(xlToRight)).Select

Selection.Copy

Workbooks.Add

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

Application.CutCopyMode = False

Columns("h:h").Select

Selection.Cut

Columns("u:u").Select

Selection.Insert Shift:=xlToRight

Columns("v:v").Select

Selection.Cut

Columns("e:e").Select

Selection.Insert Shift:=xlToRight

Columns("w:w").Select

Selection.Cut

Columns("c:c").Select

Selection.Insert Shift:=xlToRight

[Z1] = "PUSH OUT结果"

[AA1] = "COMMENT"

Columns("Y:Y").Select

Selection.Delete Shift:=xlToLeft

ActiveWorkbook.SaveAs Filename:= _

"C:\Users\5106002125\Desktop\PUSH_OUT" & Format(Date, "yyyymmdd") & Second(Now) & ".xlsx", FileFormat:= _

xlOpenXMLWorkbook, CreateBackup:=False

Windows("PUSH OUT 算法 " & b & "推进.xlsx").Activate

Sheets("Sheet1").Select

ActiveWindow.SelectedSheets.Delete

Set sh1 = Workbooks("PUSH OUT 算法 " & b & "推进")

sh1.Close

Columns("U:U").Select

Selection.Delete Shift:=xlToLeft

Columns("O:S").Select

Range("S1").Activate

Selection.Delete Shift:=xlToLeft

Range("A1:T1").Select

Range("T1").Activate

With Selection.Interior

.Pattern = xlSolid

.PatternColorIndex = xlAutomatic

.ThemeColor = xlThemeColorAccent6

.TintAndShade = 0.399975585192419

.PatternTintAndShade = 0

End With

Range("A2").Select

Range(Selection, Selection.End(xlDown)).Select

Range(Selection, Selection.End(xlToRight)).Select

Selection.Borders(xlDiagonalDown).LineStyle = xlNone

Selection.Borders(xlDiagonalUp).LineStyle = xlNone

With Selection.Borders(xlEdgeLeft)

.LineStyle = xlContinuous

.ColorIndex = xlAutomatic

.TintAndShade = 0

.Weight = xlHairline

End With

With Selection.Borders(xlEdgeTop)

.LineStyle = xlContinuous

.ColorIndex = xlAutomatic

.TintAndShade = 0

.Weight = xlHairline

End With

With Selection.Borders(xlEdgeBottom)

.LineStyle = xlContinuous

.ColorIndex = xlAutomatic

.TintAndShade = 0

.Weight = xlHairline

End With

With Selection.Borders(xlEdgeRight)

.LineStyle = xlContinuous

.ColorIndex = xlAutomatic

.TintAndShade = 0

.Weight = xlHairline

End With

With Selection.Borders(xlInsideVertical)

.LineStyle = xlContinuous

.ColorIndex = xlAutomatic

.TintAndShade = 0

.Weight = xlHairline

End With

With Selection.Borders(xlInsideHorizontal)

.LineStyle = xlContinuous

.ColorIndex = xlAutomatic

.TintAndShade = 0

.Weight = xlHairline

End With

Columns("S:T").Select

Selection.Borders(xlDiagonalDown).LineStyle = xlNone

Selection.Borders(xlDiagonalUp).LineStyle = xlNone

With Selection.Borders(xlEdgeLeft)

.LineStyle = xlContinuous

.ColorIndex = 0

.TintAndShade = 0

.Weight = xlMedium

End With

With Selection.Borders(xlEdgeTop)

.LineStyle = xlContinuous

.ColorIndex = 0

.TintAndShade = 0

.Weight = xlMedium

End With

With Selection.Borders(xlEdgeBottom)

.LineStyle = xlContinuous

.ColorIndex = 0

.TintAndShade = 0

.Weight = xlMedium

End With

With Selection.Borders(xlEdgeRight)

.LineStyle = xlContinuous

.ColorIndex = 0

.TintAndShade = 0

.Weight = xlMedium

End With

Selection.Borders(xlInsideVertical).LineStyle = xlNone

Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

Rows("2:2").Select

Range("D2").Activate

With ActiveWindow

.SplitColumn = 0

.SplitRow = 1

End With

ActiveWindow.FreezePanes = True

Rows("1:1").Select

Range("D1").Activate

Selection.AutoFilter

ActiveSheet.Range("$A$1:$Z$26903").AutoFilter Field:=15, Criteria1:="=0", _

Operator:=xlOr, Criteria2:="=#N/A"

Rows("2:2").Select

Range(Selection, Selection.End(xlDown)).Select

Selection.Delete Shift:=xlUp

Selection.AutoFilter

Rows("1:1").Select

Selection.AutoFilter

Columns("D:E").EntireColumn.AutoFit

Columns("U:AL").Select

Selection.Delete Shift:=xlToLeft

Rows("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

Range("O1").FormulaR1C1 = "=SUBTOTAL(9,R[2]C:R[2999]C)"

Range("O1").Select

Selection.Style = "Comma"

Range("S1:t1") = "担当答复"

Range("u1:v1") = "企划填写"

Range("Q2").Copy

Range("U2:v2").Select

Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _

SkipBlanks:=False, Transpose:=False

Application.CutCopyMode = False

Range("U2") = "依赖日期"

Range("V2") = "备注(新增/变更)"

Range("O1,S1,T1,V1,U1").Select

Range("U1").Activate

With Selection.Interior

.Pattern = xlSolid

.PatternColorIndex = xlAutomatic

.Color = 49407

.TintAndShade = 0

.PatternTintAndShade = 0

End With

With Selection.Font

.ThemeColor = xlThemeColorDark1

.TintAndShade = 0

End With

Columns("K:K").Select

Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

Range("K2") = "NEW_DUE_DATE(上周)"

Range("L2") = "NEW_DUE_DATE(本周)"

Sheets("Sheet2").Select

ActiveWindow.SelectedSheets.Delete

Sheets("Sheet3").Select

ActiveWindow.SelectedSheets.Delete

Sheets.Add

ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _

"Sheet1!R2C10:R1048576C19", Version:=xlPivotTableVersion14).CreatePivotTable _

TableDestination:="Sheet4!R3C1", TableName:="数据透视表1", DefaultVersion:= _

xlPivotTableVersion14

Sheets("Sheet4").Select

Cells(3, 1).Select

ActiveSheet.PivotTables("数据透视表1").AddDataField ActiveSheet.PivotTables("数据透视表1" _

).PivotFields("AMT"), "计数项:AMT", xlCount

With ActiveSheet.PivotTables("数据透视表1").PivotFields("LOCATION")

.Orientation = xlRowField

.Position = 1

End With

With ActiveSheet.PivotTables("数据透视表1").PivotFields("ALRAM")

.Orientation = xlColumnField

.Position = 1

End With

With ActiveSheet.PivotTables("数据透视表1").PivotFields("计数项:AMT")

.Caption = "求和项:AMT"

.Function = xlSum

End With

Cells.Select

Selection.Style = "Comma"

Cells.EntireColumn.AutoFit

End Sub

其他

Sub 调查汇总()

'Application.ScreenUpdating = False

Dim book1 As Workbook

Dim book2 As Workbook

path1 = ActiveWorkbook.Path

Set book1 = ActiveWorkbook

Workbooks.Add

Set book2 = ActiveWorkbook

book1.Activate

For wkbname = 1 To Worksheets.Count

Worksheets(wkbname).Select

copy_visible book1, book2

Next

book2.SaveAs Filename:=path1 & "\调查结果汇总" & Format(Date, "yyyymmdd") & Second(Now()) & ".xlsx", _

FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

End Sub

Function copy_visible(book1, book2)

Range("A2").Select

Range(Selection, Selection.End(xlDown)).Select

Range(Selection, Selection.End(xlToRight)).Select

Selection.Copy

book2.Activate

Range("A500000").Select

Range(Selection, Selection.End(xlUp)).Offset(1, 0).Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

Application.CutCopyMode = False

book1.Activate

End Function

Sub Sheet到Book()

'

' Sheet到Book

'

path1 = ActiveWorkbook.Path

book1 = ActiveWorkbook.Name

ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Copy

Workbooks.Add

ActiveSheet.Paste

ActiveWorkbook.SaveAs Filename:=path1 & "\" & Left(book1, Len(book1) - 5) & Format(Date, "yyyymmdd") & Second(Now()) & ".xlsx", _

FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

'

End Sub

Sub 清理工作表()

'

' 清理工作表 宏

'

'

Rows("1:1").Select

Range(Selection, Selection.End(xlDown)).Select

Range(Selection, Selection.End(xlToRight)).Select

Selection.Copy

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

ActiveWindow.LargeScroll ToRight:=-1

Rows("1:1").Select

Selection.End(xlDown).Offset(1, 0).Select

Range(Selection, Selection.End(xlToRight)).Select

Range(Selection, Selection.End(xlDown)).Select

Selection.Delete Shift:=xlUp

Rows("1:1").Select

Selection.End(xlToRight).Offset(0, 1).Select

Range(Selection, Selection.End(xlToRight)).Select

Range(Selection, Selection.End(xlDown)).Select

Selection.Delete Shift:=xlToLeft

End Sub

Sub 删除重复()

'

' 宏3 宏

'

'

Application.CutCopyMode = False

Selection.Copy

Sheets.Add After:=Sheets(Sheets.Count)

Columns("A:A").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

Application.CutCopyMode = False

ActiveSheet.Range("$A$1:$A$100000").RemoveDuplicates Columns:=1, Header:=xlNo

End Sub