- 帖子
- 406
- 主題
- 8
- 精華
- 0
- 積分
- 453
- 點名
- 0
- 作業系統
- WINDOWS 7
- 軟體版本
- 2007
- 閱讀權限
- 20
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2015-2-7
- 最後登錄
- 2021-7-31
|
4#
發表於 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
檔案如下
 49大樂透(主檔).rar (22.26 KB)
你另一帖需求感覺更多，光看起來就感覺有點麻煩.....
看有沒有人願意幫你，今天先這樣 |
|
