Board logo

標題: [發問] 如何尋找相同資料並複製其他欄位 [打印本頁]
作者: cslinmiso    時間: 2012-9-30 17:48     標題: 如何尋找相同資料並複製其他欄位

各位好，主題可能有點表意不清
但我的意思是想要將SHEET1中的A.B.C欄位跟SHEET2比對
若SHEET2欄位A.B.C資料跟SHEET1相符則複製該列DEF資料到SHEET2
要注意的是，SHEET2的筆數可能會變動

嘗試用vlookup寫過但不知道是哪裡卡住一直都寫不出來
後來也試著用 Application.WorksheetFunction.Match 來寫，但是小弟功力不到沒辦法將A欄 (日期) 跟B欄(時間)做比對
是否有高人可以指點如何才能達到我想要的目的呢？
如果問錯問題或者冒犯了，還請多多包涵

附圖
[attach]12646[/attach]

並附上檔案供參考
[attach]12647[/attach]
作者: hugh0620    時間: 2012-9-30 19:07

本帖最後由 hugh0620 於 2012-9-30 19:17 編輯

回復 1# cslinmiso

============================================
在使用時~ 可能要考量一下函數的意義與比對資料的方式~
您總共要比對三個欄位的資料~ 所以~ 用vlookup與match比較不適當~
vlookup用在同一欄進行比對~ 但您有三個欄位要比對~~ 寫法上不實用~ 且複雜~
可以更直覺的用if 判斷 abc三欄同一列的資料是否一樣~
============================================

個人的寫法是當您在sheet2中輸入資料~
要判斷
1. 是否在column1.2.3輸入資料
2.  column1.2.3資料是否輸入完整
3. 最後將sheet2新入輸的資料從sheet1的第一筆資料開始比對~ 找資料是否有與sheet1相符的~
    如果有就將資料抓取到sheet2

缺點: 當sheet1中有重覆的資料~ 就會被覆蓋~

提供給您參考~
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2. A = Target.Column
  3. B = Target.Row
  4. If A > 3 Then Exit Sub

  6. Select Case A
  7. Case 1
  8.      If Target.Offset(0, 1) = "" And Target.Offset(0, 2) = "" Then Exit Sub
  9. Case 2
  10.      If Target.Offset(0, -1) = "" And Target.Offset(0, 1) = "" Then Exit Sub
  11. Case 3
  12.      If Target.Offset(0, -2) = "" Or Target.Offset(0, -1) = "" Then Exit Sub
  13. End Select
  14. I = 0
  15. Do Until Sheet1.Range("A" & 2 + I) = ""
  16.    If Sheet1.Range("A" & 2 + I) = Sheet2.Range("A" & B) And Sheet1.Range("B" & 2 + I) = Sheet2.Range("B" & B) And Sheet1.Range("C" & 2 + I) = Sheet2.Range("C" & B) Then
  17.       Sheet2.Range("D" & B) = Sheet1.Range("D" & 2 + I)
  18.       Sheet2.Range("E" & B) = Sheet1.Range("E" & 2 + I)
  19.       Sheet2.Range("F" & B) = Sheet1.Range("F" & 2 + I)
  20.    End If
  21. I = I + 1
  22. Loop

  24. End Sub
複製代碼
作者: cslinmiso    時間: 2012-9-30 20:42

本帖最後由 cslinmiso 於 2012-9-30 20:44 編輯

回復 2# hugh0620

謝謝您的回應，非常感謝。
但我套用您的公式試執行後出現錯誤13 型態不符合
是否為哪裡有錯誤或者小弟哪裡弄錯了呢？
謝謝
  1. Case 1
  2.      If Target.Offset(0, 1) = "" And Target.Offset(0, 2) = "" Then Exit Sub
複製代碼
是在此發生錯誤的。
作者: hugh0620    時間: 2012-10-1 19:53

回復 3# cslinmiso

要不要把您執行有誤的檔案PO上來~ 看看問題在哪~

原本我以為是版本的問題~  (我自己是用2003)
後來用2007執行也沒有問題~
作者: GBKEE    時間: 2012-10-1 20:58

回復 1# cslinmiso
使用Dictionary物件
  1. Option Explicit
  2. Sub Ex()
  3.     Dim d As Object, Rng As Range
  4.     Set d = CreateObject("SCRIPTING.DICTIONARY")  '設立 Dictionary物件
  5.     Set Rng = Sheets("sheet1").[a2]
  6.     Do
  7.         d(Format(Rng, "yyyy/m/d") & Format(Rng.Offset(, 1), "hh:mm") & Rng.Offset(, 2)) = Rng.Offset(, 3).Resize(, 3)
  8.         '2012/9/2200:30Aaron        -> Dictionary物件的 key: Format(Rng, "yyyy/m/d") & Format(Rng.Offset(, 1), "hh:mm") & Rng.Offset(, 2)
  9.         'Rng.Offset(, 3).Resize(, 3)-> Dictionary物件的 item (D:E:F欄)
  10.         Set Rng = Rng.Offset(1)                   '變數物件 下移一列
  11.     Loop Until Rng.Value = ""                     '變數物件內容=空白字串離開迴圈
  12.     Set Rng = Sheets("sheet2").[a2]
  13.     Do
  14.         If d.Exists(Rng.Text & Rng.Offset(, 1).Text & Rng.Offset(, 2)) Then
  15.             'Exists 方法 如果在 Dictionary 物件中指定的關鍵字存在，傳回 True，若不存在，傳回 False。
  16.             Rng.Offset(, 3).Resize(, 3).Value = d(Rng & Rng.Offset(, 1).Text & Rng.Offset(, 2))
  17.              'D:F欄.Value=Dictionary物件的item
  18.         End If
  19.         Set Rng = Rng.Offset(1)
  20.     Loop Until Rng = ""
  21. End Sub
複製代碼
作者: Hsieh    時間: 2012-10-1 22:28

回復 3# cslinmiso

時間是否也要相同?
  1. Sub ex()
  2. Dim Mystr$, d As Object, A As Range
  3. Set d = CreateObject("Scripting.Dictionary")
  4. With 工作表1
  5. For Each A In .Range(.[A2], .[A2].End(xlDown))
  6.    Mystr = Join(Application.Transpose(Application.Transpose(A.Resize(, 3))), ",")
  7.    d(Mystr) = A.Offset(, 3).Resize(, 3)
  8. Next
  9. End With
  10. With 工作表2
  11. For Each A In .Range(.[A2], .[A2].End(xlDown))
  12.    Mystr = Join(Application.Transpose(Application.Transpose(A.Resize(, 3))), ",")
  13.   A.Offset(, 3).Resize(, 3) = d(Mystr)
  14. Next
  15. End With
  16. End Sub
複製代碼
作者: cslinmiso    時間: 2012-10-1 22:37

回復 5# GBKEE
非常感謝GBKEE版主，試用後得到我想要的結果:)
小弟不材還需要跟各位多討教
想請問一個問題，若今日需要在另外一份檔案搜尋(假設為Sheet1的資料)
是否將    Set Rng = Sheets("sheet1").[a2] 此行
定義成worksheet.sheet("檔名").[a2] 即可呢?

hugh0620大哥
已附上檔案
若是小弟操作方面錯誤還得見諒，此外感謝大力協助
[attach]12660[/attach]

[attach]12661[/attach]
作者: cslinmiso    時間: 2012-10-1 22:39

回復 6# Hsieh

是的，日期時間名字都必須完全符合才複製DEF欄位的資料至該欄。
謝謝協助 :)
作者: cslinmiso    時間: 2012-10-1 22:54

Hsieh 版主，您的程式也執行成功
但概念以及程式用法上，小弟尚有不解，可否請您簡述一下呢？
同是利用Dictionary物件
您的程式硬是少上許多，這其中有什麼差異呢？
謝謝

PS:小弟並非有意發這麼多次文，係為時間差，又想到問題想問。請見諒
作者: GBKEE    時間: 2012-10-2 06:38

回復 7# cslinmiso
"是否將    Set Rng = Sheets("sheet1").[a2] 此行  定義成worksheet.sheet("檔名").[a2] 即可呢?"
你試試就知道
作者: cslinmiso    時間: 2012-10-2 11:25

回復 10# GBKEE


感謝版主再次回覆，小弟會試驗看看，遇錯再發問還請指教。

此外，小弟發現之前給的檔案格式有錯誤，試用正確格式的檔案，各位大哥的程式都跑不出來了。
欄位一切都一樣，但是就是跑不出來，我重做了一次表格內容也有更動，想請各位再次指點，謝謝。

[attach]12666[/attach]

-------
另外藉此機會順便問一下小弟寫的一個程式是否可以更簡潔，或者有更好的寫法。
謝謝

相信各位都應該看得懂，不過我還是大概解釋一下
此程式是取用Week  (週數)分析.XLS 該報表內的數據
先以某欄(mytype)篩選出各項後計數填入 另外一份報表Weekly Refund report letter.xls 之 D10欄位開始13個欄位
大概即是如此
  1. Sub Macro8()
  2. Dim mySubtotal As Double
  3. Dim mytype As Variant
  4. Dim Wkabc As Variant
  5. Dim Wkvip As Variant
  6. Dim myx, myi As Integer
  7. Dim i As Integer
  8. Dim searchTerm As String
  9. Dim myArray(10) As String

  11. Application.ScreenUpdating = False '關閉螢幕更新

  13. Wkabc = Application.InputBox(prompt:="Please Input Current Week", Title:="Weekly Report Letter for ABC")
  14.    Filename = "Week " & Wkabc & "分析" & ".XLS" 'report名稱更改週數
  15. '搜尋開啟的report名稱
  16.     For i = 1 To Workbooks.Count
  17.        'Arr = Array(Workbooks(i).Name)
  18.          myArray(i) = Workbooks(i).Name
  19.             Next
  20.     GoTo Search '搜尋開啟的report名稱
  21.             
  22. Search: 'find report name contains wkabc
  23.        searchTerm = Wkabc & "分析"
  24.     'Check if a value exists in the Array
  25.     If UBound(Filter(myArray, searchTerm)) >= 0 And searchTerm <> "" Then
  26.         GoTo Filter1
  27.     Else
  28.         MsgBox "找不到此報告，確認是否輸入正確並確認檔案已經開啟"
  29.         '若找不到就停止
  30.     GoTo Weeklyvip
  31.     End If

  33. Filter1:
  34.     mytype = Array("Absent", "Client", "Computer", "Connection", "Consultant Shortage", "Disconnection", "Disconnection(Idle)", "Headset", "Instant Break (Disconnection)", "Other", "Power Outage", "System", "TE")
  35. '計數myi 13 次
  36.           For myi = 0 To 12
  37. '定義MYX為陣列 mytpe + MYI次數(即位置)
  38.           myx = (mytype(myi))

  40. ' 'Filter
  41.    Workbooks(Filename).Activate
  42.    mySubtotal = D10
  43.    Worksheets("分析").Range("$A$1:$J$250").AutoFilter Field:=9, Criteria1:=myx
  44.     'Count range
  45.     mySubtotal = Application.WorksheetFunction.Subtotal(3, Worksheets("分析").Range("B2:B250"))
  46.          Windows("Weekly Refund report letter.xls").Activate
  47.     Range("D" & myi + 10) = mySubtotal

  49. Next myi
  50.     Workbooks(Filename).Activate
  51.     ActiveSheet.Range("$A$1:$J$250").AutoFilter Field:=9 '開回篩選ALL
複製代碼
作者: GBKEE    時間: 2012-10-2 13:41

回復 11# cslinmiso
附檔 可依 5# 及 6#  Hsieh 超版 的程式 得到
只是  6#  Hsieh 超版 的程式 修改  With  工作表1  -> With Sheets("sheet1") ' 工作表1
                                                            With  工作表2  -> With Sheets("sheet2") ' 工作表2
另修改 11# 的程式碼 試試看 是否合用?
  1. Option Explicit
  2. Sub Macro8()
  3. Dim mySubtotal As Double
  4. Dim mytype As Variant
  5. Dim Wkabc As Variant
  6. Dim Wkvip As Variant
  7. Dim myx, myi As Integer
  8. Dim i As Integer
  9. Dim searchTerm As String
  10. Dim myArray(10) As String

  12. Dim Filename, Wo As Workbook, Filename_Msg As Boolean
  13. Application.ScreenUpdating = False '關閉螢幕更新
  14. Wkabc = Application.InputBox(prompt:="Please Input Current Week", Title:="Weekly Report Letter for ABC")
  15. Filename = "Week " & Wkabc & "分析" & ".XLS" 'report名稱更改週數
  16. '搜尋開啟的report名稱
  17.     For Each Wo In Workbooks
  18.          If Wo.Name = Filename Then
  19.             Filename_Msg = True
  20.             Exit For
  21.          End If
  22.     Next
  23.     If Filename_Msg = False Then
  24.         MsgBox "找不到此報告，確認是否輸入正確並確認檔案已經開啟"
  25.         Exit Sub
  26.     End If
  27.      
  28. Filter1:
  29.     mytype = Array("Absent", "Client", "Computer", "Connection", "Consultant Shortage", "Disconnection", "Disconnection(Idle)", "Headset", "Instant Break (Disconnection)", "Other", "Power Outage", "System", "TE")
  30.     For myi = 0 To 12 '計數myi 13 次
  31. ' 'Filter
  32.         Workbooks(Filename).Activate
  33.         'mySubtotal = D10      '錯誤 沒有設立變數
  34.         Worksheets("分析").Range("$A$1:$J$250").AutoFilter Field:=9, Criteria1:=mytype(myi)
  35.             'Count range
  36.         mySubtotal = Application.WorksheetFunction.Subtotal(3, Worksheets("分析").Range("B2:B250"))
  37.         Windows("Weekly Refund report letter.xls").Activate
  38.         Range("D" & myi + 10) = mySubtotal
  39.     Next myi
  40.     Workbooks(Filename).Activate
  41.     ActiveSheet.Range("$A$1:$J$250").AutoFilter Field:=9 '開回篩選ALL
  42. End Sub
複製代碼
作者: cslinmiso    時間: 2012-10-2 19:53

感謝GBKEE再次提點，試用後的確是執行正常。完美無缺。
真不知道小弟當時怎麼會一直執行後得到空白？

感謝您的修正，看見您將陣列改成for each，請問此種寫法是否比較直覺或者比較簡單呢？
小弟還是新手常常繞了一大圈。

今日還有寫了幾個還得勞駕各位看看，不過現在已經在家了，明天再勞煩各位。

再次感謝GBKEE版主以及Hsieh 超版.hugh0620 ^_^
作者: hugh0620    時間: 2012-10-2 20:39

本帖最後由 hugh0620 於 2012-10-2 21:03 編輯

回復 7# cslinmiso


    噗~ 我有下載你的檔案~ 執行後~ 並未有您說的問題耶~ 呵呵~

   不過沒關係~ 有G大跟H大~ 幫你解決了~ 你的問題~ ^^

   其實不管是G大大的寫法或是H大大的寫法
   這個要看個人的使用習慣~  您都可以參考看看~~

   不過要提醒的是~ 資料輸入時日期或是時間的格式~ 通常都會造成~
   兩個不同SHEET在比對時~ 無法將資料正確比對~
作者: GBKEE    時間: 2012-10-3 06:42

回復 13# cslinmiso
"將陣列改成for each，請問此種寫法是否比較直覺或者比較簡單呢？"
這端看個人的習慣而定
作者: cslinmiso    時間: 2012-10-4 16:09

回復 15# GBKEE

謝謝GBKEE版主提點，試用您的程式後正常。
想請問我原本的程式是比較不好還是會造成問題呢?

hugh0620 十分感謝您的幫助，我會吸收您的建議

感謝各位，今後有問題我想我應該直接接著這篇繼續問好了(如果相關的話)



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)