mycmyc

帖子: 173
主題: 42
精華: 0
積分: 220
點名: 0
作業系統: win10
軟體版本: Office 365
閱讀權限: 20
性別: 男
註冊時間: 2010-10-13
最後登錄: 2023-10-11

1^# 跳轉到 » 正序看帖

打印

字體大小: tT

發表於 2018-11-1 19:35 | 只看該作者

請教搜尋名稱　找出日期　謝謝

請教

請教.rar (7.89 KB) 我想找出濁水軀體模板有施工的日期要如何達成呢謝謝

樓主熱帖

HI

Andy2483

　暱稱: 厚臉皮的學生

大學生 Rank: 4

帖子: 1425
主題: 40
精華: 0
積分: 1449
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-4-16

21^#

發表於 2023-6-13 09:16 | 只看該作者

謝謝論壇,謝謝各位前輩
後學藉此帖學習前輩的方案,變更不同需求情境,學習方案如下,請各位前輩指教

表1 資料表:

准提部林前輩的精簡方案執行結果:

後學方案執行結果:

Option Explicit
Sub TEST()
Dim Brr, Crr, i&, j%, R&, Y&, X%, T$
Dim xR As Range, Sh1 As Worksheet, Sh2 As Worksheet
'↑宣告變數
Set Sh1 = Sheets("工作表1"): Set Sh2 = Sheets("工作表2")
'↑令變數盛裝物件(工作表)
Sh2.UsedRange.ClearContents
'↑令表2有使用儲存格清除內容
Brr = Range(Sh1.[H1], Sh1.Cells(Rows.Count, "A").End(xlUp))
'↑令Brr變數是二維陣列,以表1的A~H欄陣列值帶入陣列中
Y = UBound(Brr): X = UBound(Brr, 2)
'↑令Y變數是 Brr陣列縱向最大索引列號,令X變數是 Brr陣列橫向最大索引欄號
ReDim Crr(1 To Y, 1 To 2)
'↑令Crr變數是二維空陣列,縱向範圍同Brr陣列,橫向1~2欄
For i = 6 To Y
'↑設順迴圈
If i = 6 Then
   Crr(1, 1) = "日期"
   Crr(1, 2) = "施工項目"
   R = 1
End If
'↑如果i變數是1,先處理標題列
If Not IsDate(Brr(i, 1)) Then
'↑如果Brr陣列標題欄(日期欄)裡的值不是日期?
   MsgBox Brr(i, 1) & " 是錯誤的日期!請修正後再重新執行"
   '↑跳出提示窗 "~~~"
   Exit Sub
   '↑結束程式執行
End If
For j = 2 To X
   If Val(Brr(i, j)) > 0 Then T = T & "、" & Brr(1, j)
Next
'↑設順迴圈,將同列各欄是數值的標題以頓號間隔
R = R + 1
'↑令R變數累加1
Crr(R, 1) = Brr(i, 1)
If T <> "" Then
'↑如果T變數不是空的?
   Crr(R, 2) = Mid(T, 2)
   '↑令Crr陣列第2欄寫入施工項目集字串
   T = ""
   '↑令T變數清除內容
End If
i01: Next
Sh2.[A1].Resize(R, 2) = Crr
'↑令表2.[A1]擴展範圍儲存格值以Crr陣列值寫入
Application.Goto Sh2.[A1]
'↑令游標跳到表2.[A1]儲存格
Set Sh1 = Nothing: Set Sh2 = Nothing: Erase Brr, Crr
'↑令釋放變數
End Sub

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

20^#

發表於 2018-11-10 17:57 | 只看該作者

回復 19# mycmyc
也可用 Application.Match函數

Option Explicit
Sub Ex()
Dim Rng(1 To 2) As Range, e As Range, M As Variant, d As Object
With Sheets("工作表2")
.UsedRange.Clear
.[a1:b1] = Array("日期", "施工項目")
End With
With Sheets("工作表1")
Set Rng(1) = .Range("B6", "B" & .[A6].End(xlDown).Row).Resize(, .[A1].End(xlToRight).Column - 1).SpecialCells(xlCellTypeConstants, 1)
' *** .SpecialCells(xlCellTypeConstants, 1) 是數字的儲存格 ***
For Each e In Rng(1)
M = Application.Match(.Cells(e.Row, 1).Text, Sheets("工作表2").Columns(1), 0)
If IsError(M) Then 'Match不到 '
Set Rng(2) = Sheets("工作表2").Range("A" & Rows.Count).End(xlUp).Offset(1)
Rng(2) = .Cells(e.Row, 1).Text 'A欄的日期
Rng(2).Cells(1, 2) = .Cells(1, e.Column) '第一列的施工項目
Else
Set Rng(2) = Sheets("工作表2").Range("A" & M) 'Match到的列號
Rng(2).Cells(1, 2) = Rng(2).Cells(1, 2) & "、" & .Cells(1, e.Column)
End If
Next
End With
End Sub

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

TOP

mycmyc

中學生 Rank: 2

帖子: 173
主題: 42
精華: 0
積分: 220
點名: 0
作業系統: win10
軟體版本: Office 365
閱讀權限: 20
性別: 男
註冊時間: 2010-10-13
最後登錄: 2023-10-11

19^#

發表於 2018-11-9 21:33 | 只看該作者

回復 18# 准提部林

謝謝準大
我研究一下謝謝你熱心指導

HI

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2798
主題: 10
精華: 0
積分: 2854
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-4-15

18^#

發表於 2018-11-6 10:11 | 只看該作者

回復 16# mycmyc

若資料多, 直接用vba取出相關資料:
Sub GetDateItem()
Dim Arr, i&, j%, N&, T$
[工作表2!A:B].ClearContents
[工作表2!A1:B1] = Array("日期", "施工項目")
Arr = Range([工作表1!H1], [工作表1!A65536].End(xlUp))
For i = 6 To UBound(Arr)
If Not IsDate(Arr(i, 1)) Then GoTo 101
For j = 2 To UBound(Arr, 2)
If Val(Arr(i, j)) <> 0 Then T = T & "、" & Arr(1, j)
Next j
If T = "" Then GoTo 101
N = N + 1
Arr(N, 1) = Arr(i, 1): Arr(N, 2) = Mid(T, 2): T = ""
101: Next i
If N > 0 Then [工作表2!A2:B2].Resize(N) = Arr
Application.Goto [工作表2!A1]
End Sub

Xl0000244(日期-施工項目).rar (13.92 KB)

TOP

n7822123

　暱稱: 阿龍

中學生 Rank: 2

帖子: 406
主題: 8
精華: 0
積分: 453
點名: 0
作業系統: WINDOWS 7
軟體版本: 2007
閱讀權限: 20
性別: 男
來自: 台灣
註冊時間: 2015-2-7
最後登錄: 2021-7-31

17^#

發表於 2018-11-6 01:23 | 只看該作者

本帖最後由 n7822123 於 2018-11-6 01:28 編輯

回復 15# mycmyc

厄......沒事，我沒有要唸你的意思，

沒有人一出生就什麼都會，不用跟我說對不起

因為你在同一個Case發問的頻率有點高，所以我誤以為你想都沒想，就上來要答案，這點我誤解你了

有自己想過就OK了! ，當你卡住的時，得到答案後，印象會更深刻，下次就不會卡在同一個地方

如果沒自己想過，直接得到答案，對於答案是沒有感覺的，一模一樣的東西，換個攔列就可能卡住了

要存巨集的檔名可以是.xls(舊版) 或者 .xlsm(新版) ，

.xlsx 不會存VBA巨集，存檔後關掉再開，巨集就沒有了

程式是依需求寫的，需求表達不清楚
或者沒有上傳附件，愛莫能助

TOP

mycmyc

中學生 Rank: 2

帖子: 173
主題: 42
精華: 0
積分: 220
點名: 0
作業系統: win10
軟體版本: Office 365
閱讀權限: 20
性別: 男
註冊時間: 2010-10-13
最後登錄: 2023-10-11

16^#

發表於 2018-11-5 21:31 | 只看該作者

回復 14# 准提部林

謝謝你  我實驗確定可以
存檔是否依定要為.xlsm  巨集模式
感謝二位前輩
本人確實應該更用心學習  謝謝喔  不好意思感恩

再請教-1104-1.rar (16.69 KB)

HI

TOP

mycmyc

中學生 Rank: 2

帖子: 173
主題: 42
精華: 0
積分: 220
點名: 0
作業系統: win10
軟體版本: Office 365
閱讀權限: 20
性別: 男
註冊時間: 2010-10-13
最後登錄: 2023-10-11

15^#

發表於 2018-11-5 20:34 | 只看該作者

回復 13# n7822123
對不起  確實沒學好
原本想用自訂公式把日期下工項做一陣列  在搜尋不等於"" 列出
這樣變成每一個日期多需要一個自訂公式因此沒辦法
對不起麻煩你了  謝謝你
應該是我沒把每個函數融會貫通才卡住我再研究一下  常用那些函數
真的感恩你  謝謝

HI

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2798
主題: 10
精華: 0
積分: 2854
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-4-15

14^#

發表於 2018-11-5 12:44 | 只看該作者

回復 12# mycmyc

自訂函數:
Function GetItem(xA As Range, xB As Range) As String
Dim xR As Range, N%, TT$
For Each xR In xB
N = N + 1
If Val(xR) > 0 Then TT = TT & "、" & xA(N)
Next
GetItem = Mid(TT, 2)
End Function

K6/公式:=GetItem(B$1:H$1,INDEX(B:H,MATCH(J6,A:A,),)) 下拉

TOP

n7822123

　暱稱: 阿龍

中學生 Rank: 2

帖子: 406
主題: 8
精華: 0
積分: 453
點名: 0
作業系統: WINDOWS 7
軟體版本: 2007
閱讀權限: 20
性別: 男
來自: 台灣
註冊時間: 2015-2-7
最後登錄: 2021-7-31

13^#

發表於 2018-11-5 01:08 | 只看該作者

本帖最後由 n7822123 於 2018-11-5 01:14 編輯

回復 12# mycmyc

使用的函數都那些而已，你可以先自己研究看看，
真的寫不出來再請別人幫忙，你也可以學到東西，
如果想都不去想，就發問的話，以後遇到類似的問題，還是只能一直請別人幫忙

這次的比較複雜一點點，就先幫你了，不過我沒有把字串再接起來(你可以在別的儲存格做串接)
我寫的有些複雜，應該有更好更簡短的寫法，懶得想了，有請大神賜教!

選取K6:Q6，後輸入
=IFERROR(INDEX($A$1:$H$1,,SMALL(IF(VLOOKUP($J6,$A$6:$H$30,COLUMN($B$2:$H$2)) <> "",COLUMN($B$2:$H$2),""),COLUMN($A$1:$G$1))),"")

先按住Ctrl+Shift 再按 Enter 後放開
再往下拉

再請教-1104.rar (11.37 KB)

程式是依需求寫的，需求表達不清楚
或者沒有上傳附件，愛莫能助

TOP