利用excel VBA進行自動化數據分析，數據匯總，網頁表單自動提交等功能

本文轉載自查看原文 2017-02-17 11:47 2738 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 = 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

　　以下是通過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 = 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 = 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

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

免責聲明！

本站轉載的文章為個人學習借鑒使用，本站對版權不負任何法律責任。如果侵犯了您的隱私權益，請聯系本站郵箱yoyou2525@163.com刪除。

猜您在找 Python讀Excel數據自動化填入日常辦公的網頁表單數據分析項目數據匯總 excel vba 數據分析數據分析之--log文件自動化分析 Python辦公自動化｜一鍵生成數據分析報告 Excel數據分析之VBA入門：宏利用Python進行數據分析_Pandas_匯總和計算描述統計利用Python進行數據分析基礎系列隨筆匯總利用Python進行數據分析(9) pandas基礎: 匯總統計和計算 C#實現網頁表單自動提交