- 帖子
- 700
- 主題
- 275
- 精華
- 0
- 積分
- 1001
- 點名
- 1
- 作業系統
- Windows 10
- 軟體版本
- Office 2019
- 閱讀權限
- 50
- 性別
- 男
- 註冊時間
- 2011-6-30
- 最後登錄
- 2024-4-10
|
回復 2# samwang
由衷感謝前輩的幫助，我也努力研究學習中，並標示了註解，不知道是否有誤，還請大大有空再看，謝謝！- Dim Arr, xD, Brr(1 To 1000, 1 To 2), i&, n%, sh% '宣告變數
- Set xD = CreateObject("Scripting.Dictionary") '設定xD為字典物件
- For sh = 2 To Sheets.Count '工作表2~工作表總數,For迴圈sh(宣告為int)
- With Sheets(sh) '進入工作表,以sh代入
- Arr = .[a1].CurrentRegion '選取a1包含鄰近的所有範圍,Arr為組數
- For i = 2 To UBound(Arr) '第2列~Arr的列上限,For迴圈i(宣告為Long)
- If xD.Exists(Arr(i, 1)) Then '列是變動的，A欄是固定的，i代入列，判斷字典裡的key有沒有Arr(i, 1)，如果有就往下做
- If Not xD.Exists(Arr(i, 1) & "|" & Sheets(sh).Name) Then '如果字典裡的key沒有Arr(i, 1)就存入字典裡，連同工作表名稱
- n = n + 1: Brr(n, 1) = Arr(i, 1) '將Arr(i, 1)重複的資料存給Brr(n, 1)
- Brr(n, 2) = Sheets(sh).Name '將Arr(i, 1)重複時的工作表名稱存入Brr(n, 2)
- End If
- xD(Arr(i, 1) & "|" & Sheets(sh).Name) = "" '如果字典裡的key有Arr(i, 1)就存入字典裡，連同工作表名稱
- Else '判斷字典裡的key有沒有Arr(i, 1)，如果沒有就往下做
- xD(Arr(i, 1)) = "" '將Arr(i, 1)存入字典裡
- End If
- Next
- End With
- xD.RemoveAll '清空字典中的數據
- Next
- If n > 0 Then '如果有找到重複的資料往下做
- With Sheets("總表")
- .[a1].CurrentRegion.Offset(1) = "" '清空A、B欄數據，保留標題
- .Range("a2").Resize(n, 2) = Brr '將Brr組數釋放到A、B欄
- End With
- End If
|
|
發表於 2022-1-7 21:02
| 
