Board logo

標題: [發問] 依據InputBox填入的日期顯示資料 [打印本頁]

作者: papaya    時間: 2020-7-26 06:50     標題: 依據InputBox填入的日期顯示資料

測試檔︰[attach]32324[/attach]

請問︰以下程式的需求語法(2003版)應該如何編寫?
謝謝!

需求︰
1_先設立1個可輸入日期(yyyymmdd)的InputBox

2_在InputBox輸入X日期後,即可將該日期填入"七政","八卦","五行","六沖","合數","生肖","均值","尾數"的各工作表(以下簡稱"Arr”)的A1,
並將DATA的A欄=X日期的下1列之B︰H數值填入Arr ,如果該B︰H="”時,則Arr的A1也="”。

3_將完成第2項的"Arr"輸出為1個獨立檔案,檔案名稱="大樂透_遺漏空總統計表_輸入InputBox的日期”。
請詳見InputBox的日期=202010和20200717和20200721的三個效果檔範例。
作者: n7822123    時間: 2020-7-26 22:56

本帖最後由 n7822123 於 2020-7-26 22:58 編輯

回復 1# papaya


DATA的A欄 是"字串格式" (2020/7/7  (二)),InputBox輸入的日期也是"字串格式" (2020707)

兩個格式都是"字串" 又長的不太一樣,要怎麼比?

用拆解字串方式?  會很麻煩阿!

建議日期就回歸到日期格式,可以用自訂格式 "yyyy/mm/dd (aaa)"

日期格式可以做運算,字串格式不能

作者: papaya    時間: 2020-7-27 00:03

回復 2# n7822123
不好意思,因為剛接觸VBA,還不很清楚編寫的規矩,尚請見諒
因為DATA的資料是下載自APP軟體,所以請將DATA日期格式改為如2020/1/1,2020/7/17,2020/10/7即可,
InputBox輸入的日期格式,就配合更改後的DATA日期格式。
謝謝您
作者: n7822123    時間: 2020-7-27 00:44

本帖最後由 n7822123 於 2020-7-27 00:58 編輯

回復 3# papaya


先幫你把A欄的格式改成日期格式,我自認註解寫不少....且防呆寫不少

所以程式寫的比較長一點,希望看的懂吧~ 程式如下


Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Arr, 此表 As Worksheet, 日期 As Date, tim!, rg As Range, Rn&, xlsNm$, sh
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  '開始計時
'比對日期
For Each rg In Range([A1], [A1].End(4))
  If rg = 日期 Then Rn = rg.Row: Exit For
Next
'如果該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
'3_將完成第2項的"Arr"輸出為1個獨立檔案
With Workbooks.Add
  For i = 0 To UBound(Arr)
    ThisWorkbook.Sheets(Arr(i)).Copy After:=.Sheets(.Sheets.Count)
  Next
  .Sheets(Array(1, 2, 3)).Delete
  .SaveAs ThisWorkbook.Path & "\" & xlsNm    '沒給副檔名,舊板新版Excel都適用
  .Close True
End With
[Q2] = Round(Timer - tim, 2)
End Sub


檔案如下

[attach]32334[/attach]

你另一帖需求感覺更多,光看起來就感覺有點麻煩.....

看有沒有人願意幫你,今天先這樣

作者: papaya    時間: 2020-7-27 02:36

本帖最後由 papaya 於 2020-7-27 02:45 編輯

回復 4# n7822123
不好意思,夜深了。還勞駕您費神解題~不勝感激
測試成功
明天再仔細拜讀貴程式語法~希望自己有能力消化~再次致謝
=====================================
另一題~將全部的需求一次提出~原本是希望能讓解題的語法有其連貫性和一 致性,
沒想到反而顯得需求複雜而令人卻步~哈~哈~
作者: papaya    時間: 2020-7-27 05:27

本帖最後由 papaya 於 2020-7-27 05:30 編輯

回復 4# n7822123
不好意思,請問:
列38    .Sheets(Array(1, 2, 3)).Delete
Array(1, 2, 3)是指什麼範圍的工作表被刪除了?
謝謝您^^
作者: n7822123    時間: 2020-7-27 12:37

回復 6# papaya


Array(1, 2, 3)是指什麼範圍的工作表被刪除了?

新增活頁簿會預設有3個工作表,所以把前3個工作表刪除

你把那一行註解掉,再執行就知道是什麼了  

如果不一次寫,要分三行寫,會變成如下(連續刪除第一頁工作表,3次)


sheets(1).delete
sheets(1).delete
sheets(1).delete

作者: papaya    時間: 2020-7-27 14:49

回復 7# n7822123
謝謝您的耐心說明^^
作者: papaya    時間: 2020-7-28 01:18

本帖最後由 papaya 於 2020-7-28 01:32 編輯

回復 4# n7822123
承4#的解答(萬分感謝您詳細的文字註解)

續增需求︰
以主檔的Arr各工作表名稱(以下簡稱S)及S的B欄和C欄,搜尋.CSV轉換為.XLS後的檔案(以下簡稱D檔)名稱中之第3,4,5小段有相同"關鍵字"的檔案,
並複製D檔AZ欄=S的A1(或=InputBox輸入的日期)的日期之上1列的BA︰BS內容,貼上S之相對應E欄儲存格。
Ex1︰以InputBox=" 2020/5/15”為例~
將遺漏大數據-大樂透-七政排序-空數總覽--第二第三第四第五最末-(2020-07-21)的AZ21(2020/5/15)之上1列的BA20︰BS20內容,
貼上S=七政,B欄=,C欄=第二第三第四第五最末,E欄=E7(=1,6,12,16,17,18,26,28,36,37,38,46,48,49)。

Ex2︰以InputBox="2020/7/21”為例~
將遺漏大數據-大樂透-生肖排序-空數總覽--第二第三最末-(2020-07-21)的AZ2 (2020/7/21)之上1列的BA1︰BS1內容,
貼上S=生肖,B欄=,C欄=第二第三最末,E欄=E20(=14,16,17,18,22,25,27,31,32,33,35,48,49)。

其餘…….以此類推。

測試檔︰[attach]32336[/attach]

以上   請您繼續賜教~謝謝您^^

備註︰
1_我對VBA還是處於敲門(尚稱不上入門)階段,所以對流程順序或相關的操作方式,還不清楚,
因此相關的流程順序和比對的母子體或方式都勞駕以您的構想為宜。謝謝您!


2_為因應每執行一次的CSV(由APP產生)的A欄日期格式,所以我自行將主檔操作的日期格式改為”yyyy/m/d”。

作者: papaya    時間: 2020-7-28 06:38

本帖最後由 papaya 於 2020-7-28 06:48 編輯

忘了說明一點︰
因為只有第1次在InputBox輸入日期時,有需要用到.CSV檔案來產生.XLS檔案
其餘後續再輸入的日期,就直接比對由第1次所產生的.XLS檔案即可,
所以您只要取測試檔中的子資料夾(轉換後的XLS)內的4個XLS檔案來測試就可以了
謝謝您
作者: papaya    時間: 2020-7-28 07:02

本帖最後由 papaya 於 2020-7-28 07:11 編輯

補註 :
也就是說~由.CSV檔案來產生可與主檔的Arr各工作表相互搜尋比對的.XLS檔案,所以該.XLS檔案可重複使用。

作者: papaya    時間: 2020-7-29 01:49

本帖最後由 papaya 於 2020-7-29 01:56 編輯

回復 4# n7822123
[attach]32338[/attach]
抱歉~更正筆誤~
9樓的測試檔內之大樂透_遺漏空總統計表_0721(效果檔)的A3 :A9正確的答案應該是=""
謝謝您^^"

作者: n7822123    時間: 2020-7-29 02:51

本帖最後由 n7822123 於 2020-7-29 03:01 編輯

回復 9# papaya

厄.........你這樣敘述,我真的看不懂...............

先檔案開始說吧,為什麼你的範例1 "2020/5/15" 要找上

"將遺漏大數據-大樂透-七政排序-空數總覽-土-第二第三第四第五最末-(2020-07-21)" 這個檔案?

為什麼你的範例2 "2020/7/21" 要換成

"將遺漏大數據-大樂透-生肖排序-空數總覽-狗-第二第三最末-(2020-07-21)的AZ2 (2020/7/21)" 這個檔案?


完全看不懂有什麼關聯

還有敘述的句子,能使用

"XXX"檔案 的"OOO" 欄位 複製到 "PPP"檔案 的 "KKK"欄位

這種方式嗎?

你的敘述看的真的很亂,完全不知道是指 "檔案" 還是 "工作表" 還是 "欄位" !



作者: papaya    時間: 2020-7-29 13:17

本帖最後由 papaya 於 2020-7-29 13:30 編輯

回復 13# n7822123
不好意思,寫了一大篇,卻辭不達意

重新整理"續增需求"的說明 :
在"程式檔的圖說!"有將七政工作表名稱++第二第三第四第五最末生肖工作表名稱++第一第二第三各作1個流程說明圖解~請參考。
謝謝您^^
測試檔 : [attach]32340[/attach]

如果您尚有不明瞭之處,煩請告知,我會再作補充說明。
作者: papaya    時間: 2020-7-29 14:03

本帖最後由 papaya 於 2020-7-29 14:06 編輯

補註 :
如果搜尋的時間會耗時過長,就由我自行測試~免得耽擱您寶貴的時間。
倘若測試後,有什麼要補充的,我再提出即可。
謝謝您

作者: papaya    時間: 2020-7-29 14:48

再補註 :
測試檔中,只有列出4個被搜尋的檔案【EX :遺漏大數據-大樂透-CC排序-空數總覽-E-FFFFF-(2020-07-21)等檔案】~以利作說明範例;
然後在InputBox分次輸入 2020/5/19 和 2020/7/21 作測試。

實務上~
每輸入1個日期~執行後~
被搜尋的檔案的總個數,是=程式檔的8個工作表內的各項目+名次的全部組合個數總和;
所以執行時間會很久是正常的。
以上  請參考~謝謝您^^
作者: papaya    時間: 2020-7-29 21:52

本帖最後由 papaya 於 2020-7-29 22:06 編輯

回復 13# n7822123
[attach]32342[/attach]
將"被搜尋的檔案"總個數(共=469個)列出~以利解題。
請參考~謝謝您
=========================================
PS :
勞駕您再下載1次.Rar壓縮檔~因為將已標示格式的文字內容貼上論壇,格式會都呈現無效狀態。必須再逐一重新標示
重新標示格式的時間如超過15分鐘,就無法重新編輯~就如16樓無法在時限內完成"內文潤飾"的狀況(當時論壇系統不巧剛好有點小問題,等系統恢復後,就無法再編輯)。
謝謝您^^
作者: papaya    時間: 2020-7-29 22:37

修正"實務上被搜尋的檔案總個數"內文的筆誤~
B欄+C欄更正為B欄&C欄
作者: n7822123    時間: 2020-7-30 01:40

本帖最後由 n7822123 於 2020-7-30 01:43 編輯

回復 18# papaya


好,很清楚,我看懂了

不過我可能會反過來寫,因為這樣比較簡單

依資料夾內的檔案"檔名"搜尋一遍,

如果有對應的欄位再打開檔案,搜尋日期,

並把相應值填上,這個寫法只需跑一次迴圈(檔案迴圈)

你的步驟寫起來會比較麻煩,要三個迴圈

工作表1個迴圈(七政、八卦...)  B欄1個迴圈(土、日...)  C欄1個迴圈(第一第二...)

而且像這種少的範例檔(4個),很多欄位都找不到相對應檔案,

所以反過來用檔案找欄位,會比較有效率

我先整理一下思路,最快也要明天才能寫給你。

作者: papaya    時間: 2020-7-30 01:55

本帖最後由 papaya 於 2020-7-30 02:05 編輯

回復 19# n7822123
感謝您肯耐心看完,也很高興您看懂了

就依據您的構想編寫即可~謝謝您

不急!您肯幫忙,我就已是萬幸了

作者: n7822123    時間: 2020-7-30 12:04

回復 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


檔案如下,有問題再說嘍

[attach]32346[/attach]
作者: papaya    時間: 2020-7-30 13:48

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

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

作者: papaya    時間: 2020-7-30 17:57

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

回復 21# n7822123
測試檔 : [attach]32348[/attach]
不好意思,我遇到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欄日期格式更改為能執行的格式"之程式碼?
謝謝您^^

作者: n7822123    時間: 2020-7-30 23:19

本帖最後由 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欄位,

你再測看看,如下附件


[attach]32351[/attach]
作者: papaya    時間: 2020-7-30 23:43

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

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

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

作者: n7822123    時間: 2020-7-31 00:36

回復 25# papaya



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

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

'---------------------------------------------
'1_先設立1個可輸入日期(yyyymmdd)的InputBox
日期 = InputBox("請輸入日期,格式Ex:2020/07/07", "輸入日期")
[R2] = 日期   

作者: papaya    時間: 2020-7-31 02:53

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




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