[發問] [字典物件]列出各工作表特定值問題

各位前輩好,
小弟目前在練習時遇到一個問題,
簡述問題如下:
假設有一活頁簿,共有4個工作表,3個含有資料,第4個做為顯示結果用,
(其實當然是希望不只3個,但目前僅做為練習用,故先假定3個)
前3個工作表內均有3欄,
第1欄為編號,第2欄為名稱,第3欄為數據.
希望可以將3個工作表內第2欄名稱為"A"的數據找出,刪除重複數據並貼至第4個工作表,第1欄則重新編號.
小弟有試著修改前輩的程式碼,但結果不甚理想,不知問題出在哪裡,
斗膽上來發問,還望前輩不吝指點迷津,十分感謝.

附上檔案及程式碼以供前輩參考:

註:"希望結果"分頁的A-C欄是所期望的運行結果,
但目前程式實際運行的結果會顯示在"希望結果"分頁的F至H欄.

20161101-列出各工作表特定值問題.zip (13.12 KB)

'此為參考板上前輩程式碼進行修改,非我原創
'論壇網址:http://forum.twbts.com/
Public Sub test()
Dim arr(), brr(), myD, mNum
Set myD = CreateObject("scripting.dictionary")
ReDim brr(1 To 65536, 1 To 3)
Sheets(1).Activate
For Each sht In Sheets
arr = Range("a2:c" & Cells(Rows.Count, 1).End(xlUp).Row)
If sht.Name <> "希望結果" Then
sht.Activate
n = n + 1
For i = 1 To UBound(arr)
T = arr(i, 3)
If myD(T) = 1 Then GoTo 101
If arr(i, 2) <> "A" Then GoTo 101
For j = 2 To 3
brr(n, 1) = n
brr(i, j) = arr(i, j)
Next j
myD(T) = 1
101:
Next i
End If
Next sht
Sheets(4).Activate
If n > 0 Then [f2].Resize(n, 3) = brr
End Sub

複製代碼

樓主熱帖

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

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

2^#

發表於 2016-11-1 19:52 | 只看該作者

Public Sub test()
Dim Arr, Brr, myD, T$, N&, Sht As Worksheet
Set myD = CreateObject("scripting.dictionary")
ReDim Brr(1 To 65536, 1 To 3)
For Each Sht In Sheets
　　If Sht.Name <> "希望結果" Then
　　　　Arr = Sht.Range("a1:c" & Sht.Cells(Rows.Count, 1).End(xlUp).Row)
　　　　For i = 2 To UBound(Arr)
　　　　　　If Arr(i, 2) <> "A" Then GoTo 101
　　　　　　T = Arr(i, 3): If myD(T) = 1 Then GoTo 101
　　　　　　N = N + 1
　　　　　　Brr(N, 1) = N
　　　　　　For j = 2 To 3: Brr(N, j) = Arr(i, j): Next j
　　　　　　myD(T) = 1
101: Next i
　　　End If
Next Sht
Sheets("希望結果").Activate
If N > 0 Then [f2].Resize(N, 3) = Brr
End Sub
　
　

TOP

greetingsfromtw

中學生 Rank: 2

帖子: 45
主題: 10
精華: 0
積分: 59
點名: 0
作業系統: Win7
軟體版本: Office 2007
閱讀權限: 20
性別: 男
註冊時間: 2014-2-6
最後登錄: 2019-6-22

論壇贊助勳章

3^#

發表於 2016-11-1 22:34 | 只看該作者

回復 2# 准提部林

非常感謝淮提部林前輩的指正,
小弟十分慚愧,覺得自己進展太慢了,還得努力學習.
再次感謝前輩無私指點.

TOP