Board logo

標題: [發問] 想在原有的程式碼加入找昨日的功能 [打印本頁]
作者: starbox520    時間: 2017-1-4 10:27     標題: 想在原有的程式碼加入找昨日的功能

本帖最後由 starbox520 於 2017-1-4 10:28 編輯

[attach]26286[/attach]

此程式可在這裡輸入日期(紅線圈起部分)
會找網段上資料，依我輸入的日期之間的所有的資料
(中間有一些公式做計算)
像上圖就是會去找5月1號-5月31號的資料

現在想新增一個botten不需輸入日期
按下會直接跑昨日的資料，還請指導一下，還有這隻程式有時候會跑到1年的資料
相對的就會跑超久…最久一次跑了快2天= ="，程式碼部分有辦法優化嗎
  1. Sub Sumbit()

  3. clean_rawdata
  4.    Sheets("Act_UTZ").Select
  5.     Range("D4").Value = "手動"

  7. Dim Src As String
  8.    
  9.    
  10.     Application.DisplayAlerts = False
  11.    
  12.    
  13.     Src = ThisWorkbook.Name
  14.    
  15.     start_year = Left(Worksheets("Main").Cells(2, 2), 4)
  16.     end_year = Left(Worksheets("Main").Cells(2, 4), 4)

  18.     start_month = Mid(Worksheets("Main").Cells(2, 2), 5, 2)
  19.     end_month = Mid(Worksheets("Main").Cells(2, 4), 5, 2)
  20.    
  21.     start_day = Right(Worksheets("Main").Cells(2, 2), 2)
  22.     end_day = Right(Worksheets("Main").Cells(2, 4), 2)
  23.    
  24.     start_date = Right(Worksheets("Main").Cells(2, 2), 4)
  25.     end_date = Right(Worksheets("Main").Cells(2, 4), 4)
  26.    
  27.    
  28.     ''''plan_period為所要下載之PC Plan版本日期
  29.    
  30.    
  31.     If Val(end_month) > Val(start_month) Or Val(end_year) > Val(start_year) Then
  32.       
  33.        If start_month = "01" Or start_month = "03" Or start_month = "05" Or start_month = "07" Or start_month = "08" Or start_month = "10" Or start_month = "12" Then
  34.           m1 = 31
  35.        End If
  36.        If start_month = "02" Then
  37.           m1 = 29
  38.        End If
  39.        If start_month = "04" Or start_month = "06" Or start_month = "09" Or start_month = "11" Then
  40.           m1 = 30
  41.        End If
  42.         
  43.        plan_period = m1 - Val(start_day) + Val(end_day)
  44.       
  45.     End If
  46.       
  47.     If Val(end_month) = Val(start_month) Then
  48.    
  49.        If start_month = "01" Or start_month = "03" Or start_month = "05" Or start_month = "07" Or start_month = "08" Or start_month = "10" Or start_month = "12" Then
  50.           m1 = 31
  51.        End If
  52.        If start_month = "02" Then
  53.           m1 = 29
  54.        End If
  55.        If start_month = "04" Or start_month = "06" Or start_month = "09" Or start_month = "11" Then
  56.           m1 = 30
  57.        End If
  58.    
  59.        plan_period = Val(end_day) - Val(start_day)
  60.       
  61.     End If
  62.    
  63.             
  64.    ' Worksheets("Raw_Data_1").Select
  65.    
  66.     'Cells.Select
  67.    ' Selection.EntireColumn.Hidden = False
  68.    ' Worksheets("Raw_Data_1").AutoFilterMode = False
  69.    

  71.    
  72.     For I = 0 To plan_period
  73.    
  74.         If Val(start_day) + I > m1 Then
  75.         
  76.            If Val(start_month) <= 8 Then
  77.       
  78.               month_var = "0" & Val(start_month) + 1
  79.               
  80.            ElseIf Val(start_month) >= 12 Then
  81.       
  82.                   month_var = "0" & Val(start_month) + 1 - 12
  83.               
  84.            ElseIf Val(start_month) >= 9 Then
  85.       
  86.                   month_var = Val(start_month) + 1
  87.               
  88.            End If
  89.       
  90.            If Val(start_day) + I - m1 <= 9 Then
  91.          
  92.               day_var = "0" & Val(start_day) + I - m1
  93.               
  94.            ElseIf Val(start_day) + I - m1 >= 10 Then
  95.       
  96.                   day_var = Val(start_day) + I - m1
  97.          
  98.            End If
  99.    
  100.            plan_date = end_year & month_var & day_var
  101.            
  102.         End If
  103.         
  104. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  105.    
  106.         If Val(start_day) + I <= m1 Then
  107.                
  108.            If Val(start_day) + I <= 9 Then
  109.    
  110.               day_var = "0" & Val(start_day) + I
  111.               
  112.            ElseIf Val(start_day) + I >= 10 Then
  113.       
  114.                  day_var = Val(start_day) + I
  115.               
  116.            End If
  117.            
  118.            plan_date = start_year & start_month & day_var
  119.            
  120.         End If
  121.             
  122.       
  123.         '在""可輸入網址
  124.         Importfilepath = ""
  125.    
  126.         Set oldbook = Workbooks.Open(Importfilepath)
  127.    
  128.         'Application.AutomationSecurity = secAutomation
  129.         
  130.         
  131.         
  132. '-------------------------------------------------------------------------------------------------------------------

  134. Columns("A:X").Select
  135.     Selection.Copy
  136.     Windows(Src).Activate
  137.     Sheets("output").Select

  139.     Range("A1").Select
  140.     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  141.         :=False, Transpose:=False

  143.     Range("X2").Select
  144.     Application.CutCopyMode = False
  145.     ActiveCell.FormulaR1C1 = "=RC[-15]&RC[-20]"
  146.     Range("X2").Select
  147.     With Selection.Interior
  148.         .Pattern = xlSolid
  149.         .PatternColorIndex = xlAutomatic
  150.         .ThemeColor = xlThemeColorLight2
  151.         .TintAndShade = 0.799981688894314
  152.         .PatternTintAndShade = 0
  153.     End With
  154.     Range("X1").Select
  155.     ActiveCell.FormulaR1C1 = "$"


  158. '下拉

  160.     Dim r1 As Range

  162.     Range("A1").Select
  163.     Selection.End(xlDown).Select
  164.    
  165.     rf = ActiveCell.Offset(0, 23).Address
  166.     rtxt = "x2:" & rf
  167.     Set r1 = Range(rtxt)
  168.     r1.Select
  169.     Selection.FillDown
  170.    
  171.     '值貼上
  172.      Selection.Copy
  173.     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  174.         :=False, Transpose:=False



  178. 公式_UTZ
  179. 貼上
  180. '刷子
  181.                
  182.    
  183.         Windows("Tester_COEE&UTZ_" & plan_date & "_DailyRawData.xls").Activate
  184.         Workbooks("Tester_COEE&UTZ_" & plan_date & "_DailyRawData.xls").Close False
  185.         
  186.         
  187.         
  188.         Next
  189.         
  190.         MsgBox ("手動拉日期")
  191.         
  192.                
  193. End Sub
複製代碼
[attach]26290[/attach]
作者: stillfish00    時間: 2017-1-5 13:43

本帖最後由 stillfish00 於 2017-1-5 13:46 編輯

回復 1# starbox520
日期處理請參考
DateSerial
DateDiff
DateAdd
這幾個函數，不用自己處理得那麼麻煩
作者: starbox520    時間: 2017-1-5 15:02

回復 2# stillfish00

回大大
可以用我的程式碼舉個例子嗎
作者: starbox520    時間: 2017-1-5 16:47

回復 3# starbox520


像這樣嗎?
但我不知道這樣修過後會不會存在一些我還沒發現的Bug
  1. Sub Sumbit()


  4. clean_rawdata
  5.    Sheets("Act_UTZ").Select
  6.     Range("D4").Value = "手動"

  8. Dim Src As String
  9.    
  10.    
  11.     Application.DisplayAlerts = False
  12.    
  13.    
  14.     Src = ThisWorkbook.Name
  15.    
  16.      Dim start_d As Date, end_d As Date
  17.     start_d = DateValue(Mid(Sheets("Main").[B2], 1, 4) & "/" & Mid(Sheets("Main").[B2], 5, 2) & "/" & Mid(Sheets("Main").[B2], 7, 2))
  18.     end_d = DateValue(Mid(Sheets("Main").[D2], 1, 4) & "/" & Mid(Sheets("Main").[D2], 5, 2) & "/" & Mid(Sheets("Main").[D2], 7, 2))

  20.    
  21.     For i = start_d To end_d
  22.    
  23.         
  24.            
  25.            
  26.         plan_date = Format(i, "yyyymmdd")
  27.             
  28.       
  29.         '在""可輸入網址
  30.         Importfilepath = " "
  31.    
  32.         Set oldbook = Workbooks.Open(Importfilepath)
  33.    
  34.         'Application.AutomationSecurity = secAutomation
  35.         
  36.         
  37. '-------------------------------------------------------------------------------------------------------------------

  39. Columns("A:X").Select
  40.     Selection.Copy
  41.     Windows(Src).Activate
  42.     Sheets("output").Select

  44.     Range("A1").Select
  45.     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  46.         :=False, Transpose:=False

  48.     Range("X2").Select
  49.     Application.CutCopyMode = False
  50.     ActiveCell.FormulaR1C1 = "=RC[-15]&RC[-20]"
  51.     Range("X2").Select
  52.     With Selection.Interior
  53.         .Pattern = xlSolid
  54.         .PatternColorIndex = xlAutomatic
  55.         .ThemeColor = xlThemeColorLight2
  56.         .TintAndShade = 0.799981688894314
  57.         .PatternTintAndShade = 0
  58.     End With
  59.     Range("X1").Select
  60.     ActiveCell.FormulaR1C1 = "$$"


  63. '下拉

  65.     Dim r1 As Range

  67.     Range("A1").Select
  68.     Selection.End(xlDown).Select
  69.    
  70.     rf = ActiveCell.Offset(0, 23).Address
  71.     rtxt = "x2:" & rf
  72.     Set r1 = Range(rtxt)
  73.     r1.Select
  74.     Selection.FillDown
  75.    
  76.     '值貼上
  77.      Selection.Copy
  78.     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  79.         :=False, Transpose:=False



  83. 公式_UTZ
  84. 貼上
  85. '刷子
  86.                
  87.    
  88.         Windows("Tester_COEE&UTZ_" & plan_date & "_DailyRawData.xls").Activate
  89.         Workbooks("Tester_COEE&UTZ_" & plan_date & "_DailyRawData.xls").Close False
  90.         
  91.         
  92.         
  93.         Next
  94.         
  95.         MsgBox ("手動拉日期")
  96.         
  97.                
  98. End Sub
複製代碼
作者: stillfish00    時間: 2017-1-5 19:07

本帖最後由 stillfish00 於 2017-1-5 19:17 編輯

回復 4# starbox520
是的，倒不如說不這樣修的話跨年度查詢可能有bug
但改這個不會提升太多速度

速度的話，你用了很多的 select , copy 才是主因
一般解決方法有兩種
一種是暫時關閉Application.ScreenUpdating，跑完再打開
另一種是不要用copy , 改用如
ar = Range("A1:C3").value    '取代 copy
Range("F1").resize(ubound(ar),ubound(ar,2)).value = ar     '取代 paste
來複製資料到別的地方

另外像
r1.Select
Selection.FillDown
這種可以直接簡化成  r1.FillDown
反正有 Select 的地方能免則免(執行動作的邏輯不變下)，會快很多
作者: starbox520    時間: 2017-1-6 12:29

回復 5# stillfish00


這部分我還沒用的很熟
大大可以改一部分當參考嗎
作者: stillfish00    時間: 2017-1-6 15:44

本帖最後由 stillfish00 於 2017-1-6 15:49 編輯

回復 6# starbox520
建議你看這篇　VBA的寫作技巧與增進效能
例如
  1.            
  2.         '在""可輸入網址
  3.         Importfilepath = ""
  4.         Set oldbook = Workbooks.Open(Importfilepath)
  5.         
  6.         Columns("A:X").Select
  7.         Selection.Copy
  8.         Windows(Src).Activate
  9.         Sheets("output").Select
  10.         
  11.         Range("A1").Select
  12.         Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  13.             :=False, Transpose:=False
複製代碼
可以改成
  1.         '在""可輸入網址
  2.         Importfilepath = ""
  3.         Set oldbook = Workbooks.Open(Importfilepath)

  5.         ar = oldbook.ActiveSheet.Columns("A:X")
  6.         ThisWorkbook.Sheets("output").Range("A1").Resize(UBound(ar), UBound(ar, 2)) = ar
複製代碼
甚至不要直接用整個"A:X" column , 而是找出實際有資料的區域
作者: starbox520    時間: 2017-1-6 16:56

回復 7# stillfish00

ok

我試著改改看 謝謝!!



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)