返回列表 上一主題 發帖

[發問] 依據InputBox填入的日期顯示資料

回復 20# papaya

把Excel檔放到 同路徑下的"xls檔" 資料夾後,再執行就可以了

可自行改路徑位置(修改程式裡面的 "xlsPath")

至於一開始的csv檔,你可以另寫程式轉成xls檔

測試檔只有4個,所以不會花太長時間 (檔案越少,時間越短)

至於你原本的上百個檔案,可能會花上數分鐘

程式如下


Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Arr, 此表 As Worksheet, 日期 As Date, tim!, rg As Range, Rn&, xlsNm$, sh
Dim Key$, Item$, xlsPath$, xls檔$, K1$, K2$, K3$, Ri&
Set D = CreateObject("Scripting.Dictionary")
Arr = Array("七政", "八卦", "五行", "六沖", "生肖", "合數", "均值", "尾數")
Set 此表 = ActiveSheet
'---------------------------------------------
'1_先設立1個可輸入日期(yyyymmdd)的InputBox
日期 = InputBox("請輸入日期,格式Ex:2020/07/07", "輸入日期")
If IsEmpty(日期) Then Exit Sub
'檔案名稱="大樂透_遺漏空總統計表_輸入InputBox的日期”
xlsNm = "大樂透_遺漏空總統計表_" & Format(日期, "mmdd")
'檢查是否已有檔案(避免重覆執行)
檢查$ = Dir(ThisWorkbook.Path & "\" & xlsNm & ".xls*")
If 檢查 <> "" Then
  re% = MsgBox("此檔案已存在,請確認是否覆蓋?", vbYesNo)
  If re = vbNo Then Exit Sub Else Kill ThisWorkbook.Path & "\" & 檢查
End If
tim = Timer  '開始計時
'比對日期
Set rg = Range([A1], [A1].End(4)).Find(日期, , , xlWhole)
If Not rg Is Nothing Then Rn = rg.Row
'如果該B︰H="”時,則Arr的A1也="”
If Rn = 0 Then MsgBox "找不到日期": Exit Sub
For Each sh In Arr
  With Sheets(sh): 此表.Activate
    '2_該日期填入"七政","八卦","五行","六沖","合數","生肖","均值","尾數"的各工作表
    .[A1] = Format(日期, "yyyy/mm/dd")
    '並將DATA的A欄=X日期的下1列之B︰H數值填入
    .[A3].Resize(7) = Application.Transpose(Cells(Rn + 1, 2).Resize(, 7))
  End With
Next
'---------------------------------------------
'將欄位資料裝進字典(供後面查詢)+清空程式檔工作表資料
For Each sh In Arr: With Sheets(sh)
  Rn = [B5000].End(3).Row
  For R = 2 To Rn
    If .Cells(R, 2) <> "" Then
      '把3種關鍵字組合起來當字典的Key (C欄字串中有空白陷阱)
      Key = .Name & "-" & .Cells(R, 2) & "-" & Replace(.Cells(R, 3), " ", "")
      D(Key) = R   'Item放'列號'
      .[E2].Resize(Rn - 1, 14).ClearContents  '清空資料
    End If
  Next R
End With: Next sh
'-----------------------------------------------
xlsPath = ThisWorkbook.Path & "\xls檔\"   '統一把xls放在xls檔資料夾 -可自行修改資料夾名稱~
xls檔 = Dir(xlsPath & "*.xls*")
Do While xls檔 <> ""
  K1 = Replace(Split(xls檔, "-")(2), "排序", "")
  K2 = Split(xls檔, "-")(4)
  K3 = Split(xls檔, "-")(5)
  Key = K1 & "-" & K2 & "-" & K3
  If D.Exists(Key) Then  '查字典尋找是否有欄位
    With Workbooks.Open(xlsPath & xls檔).Sheets(1)
      'Step_3:以Step_1的A1日期(或=InputBox輸入的日期)搜尋AZ欄中的相同日期
      Set rg = .Range(.[AZ1], .[AZ1].End(4)).Find(日期, , , xlWhole)
      'Step_4:將Step_3 搜尋到的日期之上1列的BA︰BS內容,複製貼上Step_1相對應的E欄儲存格(=E7)
      If Not rg Is Nothing Then Ri = rg.Row - 1 Else .Parent.Close False: GoTo 下一檔
      此表.Parent.Sheets(K1).Cells(D(Key), "E").Resize(, 14) = .Cells(Ri, "BA").Resize(, 14).Value
      .Parent.Close False  '關閉xls檔
    End With
  End If
下一檔:  xls檔 = Dir
Loop
'-------------------------------------------------------
'3_將完成的工作表輸出為1個獨立檔案
With Workbooks.Add
  For Each sh In Arr
    此表.Parent.Sheets(sh).Copy After:=.Sheets(.Sheets.Count) '複製Arr各工作表內容
  Next
  .Sheets(Array(1, 2, 3)).Delete
  .SaveAs ThisWorkbook.Path & "\" & xlsNm    '沒給副檔名,舊板新版Excel都適用
  .Close True
End With
[Q2] = Round(Timer - tim, 2) & "秒"
End Sub


檔案如下,有問題再說嘍

大樂透.rar (679.52 KB)
程式是依需求寫的,需求表達不清楚
或者沒有上傳附件,愛莫能助

TOP

回復 21# n7822123
萬分感謝您詳細的文字註解,讓我能很快的消化程式碼的意涵,並能再將其轉成適用於今彩539的程式檔~感恩

另外~想在R2填入=InputBox輸入日期(EX : 2020/7/21);在S2填入當次完成執行的檔案個數(EX : 4個)
請問 : 程式碼要怎麼增寫?
謝謝您

TOP

本帖最後由 papaya 於 2020-7-30 18:01 編輯

回復 21# n7822123
測試檔 : 0730_TEST.rar (611.62 KB)
不好意思,我遇到1個問題~想自行嘗試解決,弄了老半天,卻一直無法解決~煩請您幫忙釋疑。謝謝您!
狀況1 :
在您的測試檔放進2個xls檔 :
遺漏大數據-大樂透-八卦排序-空數總覽-艮-第二第三第四第五最末-(2020-07-21)&遺漏大數據-大樂透-八卦排序-空數總覽-坤-第一第二第三第五最末-(2020-07-21)

以程式檔執行原來的4個xls檔和上述的2個檔~效果檔的E欄只有原來的4個xls檔的對應答案,八卦工作表的E欄為空白。

狀況2 :
將上述的程式檔和6個xls檔一到新的空資料夾,在執行程式島,效果檔的E欄全為空白。

疑惑~
為什麼狀況1的6個xls檔的AZ欄日期格式完全相同,為什麼原來的4個檔案能有有效執行,新加入的2個檔案卻不行?

如果是xls檔AZ欄的日期格式有問題,要如何增寫"將AZ欄日期格式更改為能執行的格式"之程式碼?
謝謝您^^

TOP

本帖最後由 n7822123 於 2020-7-30 23:22 編輯

回復 22# papaya


另外~想在R2填入=InputBox輸入日期(EX : 2020/7/21);在S2填入當次完成執行的檔案個數(EX : 4個)
請問 : 程式碼要怎麼增寫?  

你指的是有效的執行檔案個數吧!?  

如果比對檔案名稱有欄位,並已經打開檔案

但是在AZ欄位找不到你輸入的日期

這種情況應該不算"有效執行"吧


疑惑~
為什麼狀況1的6個xls檔的AZ欄日期格式完全相同,為什麼原來的4個檔案能有有效執行,新加入的2個檔案卻不行?

厄....我6個都成功執行了,要把xls放入"xls檔"資料夾內才會被掃描到喔~

更新計算執行檔案個數,並顯示在S2欄位,

你再測看看,如下附件


大樂透_0730_TEST.rar (696.08 KB)
程式是依需求寫的,需求表達不清楚
或者沒有上傳附件,愛莫能助

TOP

本帖最後由 papaya 於 2020-7-30 23:45 編輯

回復 24# n7822123
哈~哈~誤解您的意思了
原來主檔不能放進同1個資料夾內。

另外~想在R2填入=InputBox輸入的日期(EX : 2020/7/17或2020/7/21)
程式碼應該如何編寫?
謝謝您

TOP

回復 25# papaya



另外~想在R2填入=InputBox輸入的日期(EX : 2020/7/17或2020/7/21)
程式碼應該如何編寫?

添加一行就可以了,如下~

'---------------------------------------------
'1_先設立1個可輸入日期(yyyymmdd)的InputBox
日期 = InputBox("請輸入日期,格式Ex:2020/07/07", "輸入日期")
[R2] = 日期   
程式是依需求寫的,需求表達不清楚
或者沒有上傳附件,愛莫能助

TOP

回復 26# n7822123
萬分感謝您的耐心幫忙~感恩

TOP

        靜思自在 : 要比誰更受誰.不要比誰更怕誰。
返回列表 上一主題