返回列表下一主題上一主題發帖

請問不知可否寫程式帶出可用機台

Qektyyrwp

中學生 Rank: 2

帖子: 21
主題: 5
精華: 0
積分: 58
點名: 0
作業系統: Win8
軟體版本: Excel 2.0
閱讀權限: 20
註冊時間: 2016-3-17
最後登錄: 2024-1-13

1^# 跳轉到 » 倒序看帖

打印

字體大小: tT

發表於 2016-4-15 00:54 | 只看該作者

請問不知可否寫程式帶出可用機台

將ID輸入後，B16,B17,B18可以自動帶出來，如果無法寫在同一格儲存格，分開也可以。麻煩大大們幫看看。

ID.zip (5.72 KB)

樓主熱帖

luhpro

高中生 Rank: 3 Rank: 3

帖子: 824
主題: 6
精華: 0
積分: 904
點名: 0
作業系統: Win 10,7
軟體版本: 2019,2013,2003
閱讀權限: 50
性別: 男
註冊時間: 2010-5-3
最後登錄: 2023-12-24

2^#

發表於 2016-4-16 04:53 | 只看該作者

回復 1# Qektyyrwp

Sub nn()
Dim lRow&
Dim vD, vTemp
Set vD = CreateObject("Scripting.Dictionary")
lRow = 2
While Cells(lRow, 1) <> ""
If Left(Cells(lRow, 3), 4) <> "nona" Then ' 可用才加入
If vD.exists(CStr(Cells(lRow, 1))) Then
If vD(CStr(Cells(lRow, 1))) = "" Then
vD(CStr(Cells(lRow, 1))) = Cells(lRow, 2)
Else
vD(CStr(Cells(lRow, 1))) = vD(CStr(Cells(lRow, 1))) & "," & Cells(lRow, 2)
End If
Else
vD(CStr(Cells(lRow, 1))) = Cells(lRow, 2)
End If
Else
vD(CStr(Cells(lRow, 1))) = ""
End If
lRow = lRow + 1
Wend
[A16:B50].Clear
lRow = 16
For Each vTemp In vD
Cells(lRow, 1) = vTemp
If vD(vTemp) <> "" Then
Cells(lRow, 2) = vD(vTemp)
Else
Cells(lRow, 2) = "無"
End If
lRow = lRow + 1
Next
End Sub

複製代碼

寫程式帶出可用機台-a.zip (13.92 KB)

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

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

3^#

發表於 2016-4-16 12:17 | 只看該作者

若是機台不多，可考慮自訂函數，彈性較佳：
Function GET_V(xArea As Range, xA$) As String
Dim Arr, T$, i&
Arr = xArea.Value
For i = 1 To UBound(Arr)
　　If Arr(i, 1) = xA And Left(Arr(i, 3), 3) <> "non" Then T = T & "," & Arr(i, 2)
Next i
If T = "" Then GET_V = "無" Else GET_V = Mid(T, 2)
End Function
　
公式用法：
=get_v(A$2:C$12, A16)
=get_v(資料範圍, 查詢ID)