- 帖子
- 406
- 主題
- 8
- 精華
- 0
- 積分
- 453
- 點名
- 0
- 作業系統
- WINDOWS 7
- 軟體版本
- 2007
- 閱讀權限
- 20
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2015-2-7
- 最後登錄
- 2021-7-31
|
回復 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)
|
|
發表於 2020-7-30 12:04
| 
