返回列表 上一主題 發帖

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

av8d

帖子
703 
主題
276 
精華
0 
積分
1005 
點名
1  
作業系統
Windows 10 
軟體版本
Office 2019 
閱讀權限
50 
性別
男 
註冊時間
2011-6-30 
最後登錄
2024-5-29 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2012-8-23 12:14 | 只看該作者

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

  1. Private Sub cmdMerge_Click()
  2. Application.ScreenUpdating = False '屏蔽屏幕刷新

  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

  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 '切換視窗

  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

  89.         '選取目的
  90.         Windows(desc).Activate

  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
複製代碼
收藏 分享

        靜思自在 : 世上有兩件事不能等：一、孝順 二、行善。
返回列表 上一主題