利用excel 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 = 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 = 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

 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计算
 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

 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 = VENDOR_CD
36         .document.getElementById("SLIP_NO:Upper").Value = 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 = Cells(j + row_base, 6)
44         .document.getElementById("SLIP_CUR:Upper").Value = Cells(j + row_base, 7)
45         .document.getElementById("TRADE_TYPE_LIST").Value = 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 = 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 = 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 = Cells(j + row_base, 10).Offset(k - 1, 0)
88         ‘.document.getElementById("INVG0500_LIST(" & k - 1 & "/UNIT_PRICE").Value = 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 = "√"
96         
97     End With
98 End Function

  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