返回列表 上一主題 發帖

[發問] EXCEL 比對資料問題

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
1# 跳轉到 »
發表於 2012-12-21 09:41 | 顯示全部帖子
回復 1# tmde987
對於你的說明,不很了解,試看看是這方向嗎?
  1. Sub CommandButton4_Click()
  2.     With Workbooks.Open("C:\Documents and Settings\901755\桌面\捷徑(含manual)\2.xls")
  3.         .Sheets(1).Range("B:C,O:O").Copy Workbooks("compareab_v3.xls").Sheets("資料A").Range("A1")
  4.         .Sheets(1).Range("L:L").Copy Workbooks("compareab_v3.xls").Sheets("資料A").Range("D1")
  5.         .Close
  6.    End With
  7. End Sub
複製代碼
  1. Sub CommandButton5_Click()
  2.   'Workbooks.Open Filename:="C:\Documents and Settings\901755\桌面\捷徑(含manual)\3.xls"
  3.      With WorkbooksOpen("C:\Documents and Settings\901755\桌面\捷徑(含manual)\3.xls")
  4.         .Sheets(1).Range("B:C,O:O").Copy Workbooks("compareab_v3.xls").Sheets("資料B").Range("A1")
  5.         .Sheets(1).Range("L:L").Copy Workbooks("compareab_v3.xls").Sheets("資料B").Range("D1")
  6.         .Close
  7.    End With
  8. End Sub
複製代碼
  1. Option Explicit
  2. Sub Ex_資料比對()
  3.     Dim D As Object, Rng As Range, K As Variant, Msg As Boolean, xi As Integer
  4.     Set D = CreateObject("SCRIPTING.DICTIONARY")
  5.     Sheets("資料A").Cells.Font.ColorIndex = 0
  6.     Sheets("資料B").Cells.Font.ColorIndex = 0
  7.     Sheets("資料A缺少的").Cells.Clear
  8.     Sheets("資料B缺少的").Cells.Clear
  9.     Set Rng = Sheets("資料A").[A1]
  10.     Do While Rng <> ""
  11.         Set D(Rng & Rng(1, 2)) = Rng.Resize(, 4)
  12.         Set Rng = Rng.Offset(1)
  13.     Loop
  14.     Set Rng = Sheets("資料B").[A2]
  15.     Do While Rng <> ""
  16.         Msg = False
  17.        If D(Rng & Rng(1, 2)).Cells(3) <> Rng(1, 3) Then
  18.             Msg = True
  19.             D(Rng & Rng(1, 2)).Cells(3).Font.Color = vbRed
  20.             Rng(1, 3).Font.Color = vbRed
  21.         End If
  22.        If D(Rng & Rng(1, 2)).Cells(4) <> Rng(1, 4) Then
  23.             Msg = True
  24.             D(Rng & Rng(1, 2)).Cells(4).Font.Color = vbRed
  25.             Rng(1, 4).Font.Color = vbRed
  26.         End If
  27.         If Msg = True Then
  28.             xi = xi + 1
  29.             Sheets("資料A缺少的").Cells(xi, "a").Resize(1, 4) = D(Rng & Rng(1, 2)).Value
  30.             Sheets("資料B缺少的").Cells(xi, "a").Resize(1, 4) = Rng.Resize(1, 4).Value
  31.         Else
  32.             D.Remove (Rng & Rng(1, 2))
  33.         End If
  34.        Set Rng = Rng.Offset(1)
  35.     Loop
  36.     With Sheets("資料A與B都有的")
  37.         If D.Count > 0 Then
  38.             .Cells.Clear
  39.             xi = 1
  40.             For Each K In D.KEYS
  41.                .Cells(xi, "a").Resize(1, 4) = D(K).Value
  42.                xi = xi + 1
  43.             Next
  44.         End If
  45.     End With
  46. End Sub
複製代碼

TOP

        靜思自在 : 君子為目標，小人為目的。
返回列表 上一主題