- 帖子
- 1429
- 主題
- 40
- 精華
- 0
- 積分
- 1453
- 點名
- 0
- 作業系統
- Windows 7
- 軟體版本
- Excel 2010 & 2016
- 閱讀權限
- 50
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2020-7-15
- 最後登錄
- 2024-5-18
|
2#
發表於 2022-12-21 15:21
| 只看該作者
本帖最後由 Andy2483 於 2022-12-21 15:25 編輯
回復 1# 013160
謝謝前輩發表此主題與範例檔案
後學藉此主題學習到很多知識,但不知是否符合前輩情境需求,請試試看
輸入窗: 預先置入今天日期
按確定後:
輸入: 12/22
輸入: 12/23
程式碼如下:
Option Explicit
Sub 符合多條件帶出相關資訊_20221221_1()
Dim Arr(4), Brr, Crr, i&, Y, T
Dim Sh As Worksheet, Da, N&, j%, We
Set Y = CreateObject("Scripting.Dictionary")
Set Sh = ActiveSheet
Brr = Range(Sh.[A1], Sh.UsedRange)
Da = InputBox("請輸入 日期!", "符合多條件帶出相關資訊", Date)
If Not IsDate(Da) Then Exit Sub
We = Right(Format(Da, "aaaa"), 1)
T = Array(5, 1, 2, 3, 4)
For i = 2 To UBound(Brr)
If Trim(Brr(i, 3)) = "" Then Exit For
If InStr(Brr(i, 3), We) Then
If N = 0 Then
Crr = Arr
For j = 0 To UBound(T)
Crr(j) = Brr(1, T(j))
Next
N = N + 1
Y(N) = Crr
End If
N = N + 1
Crr = Arr
For j = 0 To UBound(T)
Crr(j) = Brr(i, T(j))
Next
Y(N) = Crr
End If
Next
If N = 0 Then Exit Sub
Workbooks.Add
[A2].Resize(N, UBound(Arr) + 1) = Application.Transpose(Application.Transpose(Y.ITEMS))
Range([A1], ActiveSheet.UsedRange).Borders.LineStyle = 1
Cells.Columns.AutoFit
[2:2].Font.Bold = True
[A1].NumberFormatLocal = "m""月""d""日"";@"
[A1] = Da: [B1] = We
Set Y = Nothing
Set Brr = Nothing
Erase Crr, Arr
End Sub |
|
發表於 2022-12-21 19:28
| 
