[發問] 如何讓此程式效率提高?

av8d

1. Private Sub cmdMerge_Click()
   
2. Application.ScreenUpdating = False '屏蔽屏幕刷新
   
3. 
   
4.     Dim a, b, c As Integer '宣告a,b,c為整數
   
5.    
   
6.     Dim objsheet As Worksheet
   
7.    
   
8.     WorkName = Excel.ActiveWorkbook.Name '此檔案名稱
   
9.    
   
10.     desc = Excel.Workbooks.Add.Name '新檔案視窗編號
    
11.    
    
12.    
    
13.     Application.DisplayAlerts = False  '將警告訊息關閉
    
14.    
    
15.    
    
16.         
    
17.     i = 6
    
18. 
    
19.     z = 1
    
20.    
    
21.     While Windows(WorkName).ActiveSheet.Range("b" & i) <> ""
    
22.    
    
23.         
    
24.         Filename = Windows(WorkName).ActiveSheet.Range("b" & i) & "." & Windows(WorkName).ActiveSheet.Range("b3")
    
25.         
    
26.         Workbooks.Open Filename:=Excel.Workbooks(WorkName).Path & "\" & Filename
    
27.         
    
28.         
    
29.         sheetname = Windows(WorkName).ActiveSheet.Range("b4")
    
30.         
    
31.         If sheetname <> "" Then
    
32.             
    
33.             '檢查活頁是否存在
    
34.             flag = 0
    
35.             For j = 1 To Windows(Filename).Parent.Sheets.Count
    
36.                 If Windows(Filename).Parent.Sheets(j).Name = sheetname Then
    
37.                    flag = 1
    
38.                    Exit For
    
39.                 End If
    
40.             Next
    
41.             
    
42.             If flag = 1 Then
    
43.                 Windows(Filename).Parent.Sheets(sheetname).Select  '切換活頁
    
44.             End If
    
45.                
    
46.         End If
    
47.         Set objsheet = Windows(Filename).ActiveSheet '切換視窗
    
48. 
    
49.         '讀取來源檔案的X(列數),Y(行數)
    
50.         x = Windows(WorkName).ActiveSheet.Range("b1")
    
51.         y = Windows(WorkName).ActiveSheet.Range("b2")
    
52.         
    
53.         
    
54.         a = x '開始列
    
55.         b = y '開始欄
    
56.       
    
57.         Do While True
    
58.             kk = ""
    
59.             For l = 1 To 10
    
60.                 For k = 1 To 30
    
61.                     If IsError(objsheet.Cells(x + l, k)) = False Then
    
62.                         kk = kk & objsheet.Cells(x + l, k)
    
63.                     End If
    
64.                 Next
    
65.             Next
    
66.             If kk = "" Then Exit Do
    
67.             x = x + 1
    
68.         Loop
    
69.         
    
70.         Do While True
    
71.             kk = ""
    
72.             For l = 1 To 10
    
73.                 For k = 1 To 30
    
74.                     If IsError(objsheet.Cells(k, y + l)) = False Then
    
75.                         kk = kk & objsheet.Cells(k, y + l)
    
76.                     End If
    
77.                 Next
    
78.             Next l
    
79.             If kk = "" Then Exit Do
    
80.             y = y + 1
    
81.         Loop
    
82.         
    
83.         '選取來源範圍
    
84.          objsheet.Range(objsheet.Cells(a, b), objsheet.Cells(x, y)).Select
    
85.          
    
86.          'copy
    
87.          Selection.Copy
    
88. 
    
89.         '選取目的
    
90.         Windows(desc).Activate
    
91. 
    
92.         
    
93.         
    
94.         '如果貼上以後會大於1048576則新增一個活頁
    
95.         If (z + x - a + 1) > 65535 Then
    
96.             z = 1
    
97.             Windows(desc).Parent.Sheets.Add
    
98.             Windows(desc).Parent.Sheets(1).Cells(z, 1).Select
    
99.         Else
    
100.             If UCase(Sheet1.Range("b5").Value) = "Y" Then
     
101.                 Windows(desc).ActiveSheet.Cells(z, 1).Value = Windows(WorkName).ActiveSheet.Range("b" & i)
     
102.                 Windows(desc).ActiveSheet.Cells(z, 2).Select
     
103.             Else
     
104.                 Windows(desc).ActiveSheet.Cells(z, 1).Select
     
105.             End If
     
106.         End If
     
107.         
     
108.         ActiveSheet.Paste
     
109.                
     
110.         '貼上欄寬
     
111.         Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
     
112.         SkipBlanks:=False, Transpose:=False
     
113.                         
     
114.         z = z + x - a + 1
     
115.       
     
116.        '將來源檔案關閉
     
117.        Windows(Filename).Close
     
118.         
     
119.         i = i + 1 '讀取下一個檔案名稱
     
120.     Wend
     
121.    
     
122.     Windows(desc).ActiveSheet.Cells(1, 1).Select
     
123.    
     
124.     '版面設定上下左右0.5
     
125.         With ActiveSheet.PageSetup
     
126.         .PrintTitleRows = ""
     
127.         .PrintTitleColumns = ""
     
128.     End With
     
129.     ActiveSheet.PageSetup.PrintArea = ""
     
130.     With ActiveSheet.PageSetup
     
131.         .LeftHeader = ""
     
132.         .CenterHeader = ""
     
133.         .RightHeader = ""
     
134.         .LeftFooter = ""
     
135.         .CenterFooter = ""
     
136.         .RightFooter = ""
     
137.         .LeftMargin = Application.InchesToPoints(0.196850393700787)
     
138.         .RightMargin = Application.InchesToPoints(0.196850393700787)
     
139.         .TopMargin = Application.InchesToPoints(0.196850393700787)
     
140.         .BottomMargin = Application.InchesToPoints(0.196850393700787)
     
141.         .HeaderMargin = Application.InchesToPoints(0.511811023622047)
     
142.         .FooterMargin = Application.InchesToPoints(0.511811023622047)
     
143.         .PrintHeadings = False
     
144.         .PrintGridlines = False
     
145.         .PrintComments = xlPrintNoComments
     
146.         .PrintQuality = 600
     
147.         .CenterHorizontally = False
     
148.         .CenterVertically = False
     
149.         .Orientation = xlPortrait
     
150.         .Draft = False
     
151.         .PaperSize = xlPaperA4
     
152.         .FirstPageNumber = xlAutomatic
     
153.         .Order = xlDownThenOver
     
154.         .BlackAndWhite = False
     
155.         .Zoom = 100
     
156.         .PrintErrors = xlPrintErrorsDisplayed
     
157.     End With
     
158.    
     
159.     'A:F遞增排序
     
160.     ActiveSheet.Columns("A:F").Select
     
161.     Selection.Sort Key1:=ActiveSheet.Range("C2"), Order1:=xlAscending, Header:=xlGuess, _
     
162.         OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
     
163.         :=xlStroke, DataOption1:=xlSortNormal
     
164.    
     
165.     '資料剖析
     
166.     ActiveSheet.Columns("D:D").Select
     
167.     Selection.Insert Shift:=xlToRight
     
168.     ActiveSheet.Columns("C:C").Select
     
169.     Selection.TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, _
     
170.         TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
     
171.         Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
     
172.         :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
     
173.         
     
174.     '整理
     
175.     ActiveSheet.Range("C1").Select
     
176.     ActiveCell.FormulaR1C1 = "菜名"
     
177.     ActiveSheet.Range("D1").Select
     
178.     ActiveCell.FormulaR1C1 = "單價"
     
179.     ActiveSheet.Columns("D:D").ColumnWidth = 5.63
     
180.    
     
181.     Application.DisplayAlerts = True  '將警告訊息打開
     
182.    
     
183. Application.ScreenUpdating = True '取消屏蔽屏幕刷新
     
184. End Sub

複製代碼