返回列表 上一主題 發帖

如何將同檔案中兩sheet作比較，再將比較結果另存其他sheet中?

register313
　頭銜: 麻辣 路人甲

大學生Rank: 4

帖子
967 
主題
0 
精華
0 
積分
1001 
點名
0  
作業系統
WIN XP 
軟體版本
OFFICE 2003 
閱讀權限
50 
性別
男 
來自
台北 
註冊時間
2010-11-29 
最後登錄
2022-5-17 

2012龍年全勤獎章熱烈參與勳章
1# 跳轉到 »
發表於 2012-5-24 18:51 | 顯示全部帖子
回復 1# ckl520

設sheet2~sheet6 之A欄為P/N , B欄為Location
  1. Sub XX()
  2. Dim d1 As Object, d2 As Object, A As Range
  3. Dim Ar, Br()
  4. Set d1 = CreateObject("Scripting.Dictionary")
  5. Set d2 = CreateObject("Scripting.Dictionary")
  6. With Sheet2
  7.   For Each A In .Range("A2:A" & .[A2].End(xlDown).Row)
  8.     d1.Add A.Value, A.Offset(0, 1).Value
  9.   Next
  10. End With
  11. With Sheet3
  12. For Each A In .Range("A2:A" & .[A2].End(xlDown).Row)
  13.     d2.Add A.Value, A.Offset(0, 1).Value
  14.   Next
  15. End With
  16. S = 1
  17. Ar = d1.keys
  18. ReDim Preserve Br(1 To d1.Count + d2.Count, 1 To 2)
  19. For I = LBound(Ar) To UBound(Ar)
  20.   If d2.Exists(Ar(I)) Then
  21.      Br(S, 1) = Ar(I): Br(S, 2) = d1(Ar(I)): d1.Remove (Ar(I)): S = S + 1
  22.      Br(S, 1) = Ar(I): Br(S, 2) = d2(Ar(I)): d2.Remove (Ar(I)): S = S + 1
  23.   End If
  24. Next I
  25. For I = 4 To 6
  26.   Sheets(I).[A:B] = ""
  27.   Sheets(I).[A1:B1] = Array("P/N", "Location")
  28. Next I
  29. Sheet4.[A2].Resize(UBound(Br, 1), 2) = Br
  30. Sheet5.[A2].Resize(d1.Count, 1) = Application.Transpose(d1.keys)
  31. Sheet5.[B2].Resize(d1.Count, 1) = Application.Transpose(d1.items)
  32. Sheet6.[A2].Resize(d2.Count, 1) = Application.Transpose(d2.keys)
  33. Sheet6.[B2].Resize(d2.Count, 1) = Application.Transpose(d2.items)
  34. End Sub
複製代碼

TOP

register313
　頭銜: 麻辣 路人甲

大學生Rank: 4

帖子
967 
主題
0 
精華
0 
積分
1001 
點名
0  
作業系統
WIN XP 
軟體版本
OFFICE 2003 
閱讀權限
50 
性別
男 
來自
台北 
註冊時間
2010-11-29 
最後登錄
2022-5-17 

2012龍年全勤獎章熱烈參與勳章
2#
發表於 2012-6-1 16:02 | 顯示全部帖子
回復 3# ckl520

請上傳excel壓縮檔

TOP

register313
　頭銜: 麻辣 路人甲

大學生Rank: 4

帖子
967 
主題
0 
精華
0 
積分
1001 
點名
0  
作業系統
WIN XP 
軟體版本
OFFICE 2003 
閱讀權限
50 
性別
男 
來自
台北 
註冊時間
2010-11-29 
最後登錄
2022-5-17 

2012龍年全勤獎章熱烈參與勳章
3#
發表於 2012-6-1 19:00 | 顯示全部帖子
回復 5# ckl520
1.工作表code name 改為 name
2.修正 sheet4~sheet6 A欄 會變為日期格式之問題
  1. Private Sub CommandButton1_Click()
  2. Dim d1 As Object, d2 As Object, A As Range
  3. Dim Ar, Br() As String, Cr
  4. Set d1 = CreateObject("Scripting.Dictionary")
  5. Set d2 = CreateObject("Scripting.Dictionary")
  6. With Sheets("Sheet2")
  7.   For Each A In .Range("A2:A" & .[A2].End(xlDown).Row)
  8.     d1.Add A.Value, A.Offset(0, 1).Value
  9.   Next
  10. End With
  11. With Sheets("Sheet3")
  12. For Each A In .Range("A2:A" & .[A2].End(xlDown).Row)
  13.     d2.Add A.Value, A.Offset(0, 1).Value
  14.   Next
  15. End With
  16. S = 1
  17. Ar = d1.keys
  18. ReDim Preserve Br(1 To d1.Count + d2.Count, 1 To 2)
  19. For I = LBound(Ar) To UBound(Ar)
  20.   If d2.Exists(Ar(I)) Then
  21.      Br(S, 1) = Ar(I): Br(S, 2) = d1(Ar(I)): d1.Remove (Ar(I)): S = S + 1
  22.      d2.Remove (Ar(I)): S = S + 1
  23.   End If
  24. Next I
  25. For I = 4 To 6
  26.   Sheets("Sheet" & I & "").[A:B] = ""
  27.   Sheets("Sheet" & I & "").[A1:B1] = Array("P/N", "Location")
  28.   Sheets("Sheet" & I & "").[A:B].NumberFormatLocal = "@"
  29. Next I
  30. Sheets("Sheet4").[A2].Resize(UBound(Br, 1), 2) = Br
  31. Sheets("Sheet5").[A2].Resize(d1.Count, 1) = Application.Transpose(d1.keys)
  32. Sheets("Sheet5").[B2].Resize(d1.Count, 1) = Application.Transpose(d1.items)
  33. Sheets("Sheet6").[A2].Resize(d2.Count, 1) = Application.Transpose(d2.keys)
  34. Sheets("Sheet6").[B2].Resize(d2.Count, 1) = Application.Transpose(d2.items)
  35. End Sub
複製代碼

TOP

        靜思自在 : 話多不如話少，話少不如話好。
返回列表 上一主題