Board logo

標題: [發問] 改善大筆資料處理 [打印本頁]
作者: li_hsien    時間: 2014-1-21 10:24     標題: 改善大筆資料處理

請問各位大大

小弟我目前有兩個工作表

依據"產品工作表"(A) 的 ID & PartNumber 比對到 "物料工作表"(B) 的 ID & PartNumber

如果有一樣的，則把A的資料COPY到B裡面

如果沒有相同的，則補到B的最下方


資料量小的時候還可以

但我資料有幾千筆會變好慢好慢 大約要跑10分鐘左右

可能是FOR迴圈的問題

不知有什麼改善方法

麻煩各位大大

以下為附檔

P.S. 比對欄位有刪減，所以附檔的處理速度好像還可以

[attach]17329[/attach]
作者: GBKEE    時間: 2014-1-21 14:55

本帖最後由 GBKEE 於 2014-1-22 14:52 編輯

回復 1# li_hsien

改用 Collection 物件 不用 Dictionary 物件
  1. Option Explicit
  2. Sub Ex()
  3.     Dim d As New Collection, AR(1 To 7), i As Integer, Rng(1 To 2) As Range, E As Variant
  4.     On Error Resume Next              '註解1 :Collection新增的KEY如被使用或有錯誤
  5.     With Worksheets("產品管控清單")
  6.         For i = 2 To .Range("J1").End(xlDown).Row
  7.             AR(1) = .Range("E" & i)             'PRODUCT ID(A)
  8.             AR(2) = .Range("F" & i)             'CHILDPARTNUMBER(B)
  9.             AR(3) = .Range("C" & i)             'MP date(G)
  10.             AR(4) = .Range("A" & i)             '週別(H)
  11.             AR(5) = .Range("B" & i)             '更新週別(I)
  12.             AR(6) = DateDiff("d", Date, AR(3))  '工作日(M)
  13.             AR(7) = .Range("J" & i)             'Product ID & PartNumber
  14.             d.Add AR, .Range("J" & i).Value     '紀錄產品的ID & PartNumber
  15.             
  16.             '**** 所以是以"產品"擁有的為主，不過產出"物料"之前得先刪除"產品"重複的部分->Rng(1)
  17.             '**** 當產品的ID & PartNumber(F)有重複時有->註解1: Err <> 0
  18.             If Err <> 0 Then
  19.                 Err.Clear
  20.                 If Rng(1) Is Nothing Then       'Rng(1)->紀錄有重複產品的ID & PartNumber
  21.                     Set Rng(1) = .Range("J" & i)
  22.                 Else
  23.                     Set Rng(1) = Union(.Range("J" & i), Rng(1))
  24.                 End If
  25.             End If
  26.         Next
  27.     End With
  28.     With Worksheets("物料管控清單")
  29.         For Each E In .Range("F:F").SpecialCells(xlCellTypeConstants).Offset(1)
  30.             .Range("A" & E.Row) = d(E.Value)(1)
  31.             .Range("B" & E.Row) = d(E.Value)(2)
  32.             .Range("G" & E.Row) = d(E.Value)(3)
  33.             .Range("H" & E.Row) = d(E.Value)(4)
  34.             .Range("I" & E.Row) = d(E.Value)(5)
  35.             .Range("M" & E.Row) = d(E.Value)(6)
  36.             .Range("F" & E.Row) = d(E.Value)(7)
  37.             
  38.             '**** "產品"有 "物料"有  則把 "產品" 的資料COPY到 "物料" 原本的位子上
  39.             '**** 產品"有 "物料"有 -> Err = 0
  40.             If Err = 0 Then                     '物料的ID & PartNumber,存在產品的ID & PartNumber中
  41.                 d.Remove E.Value                '除去:產品的ID & PartNumber
  42.             '**** 有第二筆已除去的產品ID & PartNumber-> 已除去(沒有這KEY值): Err <> 0
  43.             ElseIf Err <> 0 And E <> "" Then
  44.             '**** "產品"沒有 "物料"有 則把"物料"整欄刪除掉 -> Rng(2)
  45.                 If Rng(2) Is Nothing Then       '取的儲存格的位置
  46.                     Set Rng(2) = E
  47.                 Else
  48.                     Set Rng(2) = Union(E, Rng(2))
  49.                 End If
  50.             End If
  51.             Err.Clear
  52.         Next
  53.         If d.Count > 0 Then
  54.             
  55.             'C ***產品"有 "物料"沒有 則把新增多出來的增加到 "物料" 最下面
  56.             i = 0
  57.             With .Range("A1").End(xlDown)
  58.                 For Each E In d
  59.                     i = i + 1
  60.                     .Offset(i).Range("A1") = E(1)
  61.                     .Offset(i).Range("B1") = E(2)
  62.                     .Offset(i).Range("G1") = E(3)
  63.                     .Offset(i).Range("H1") = E(4)
  64.                     .Offset(i).Range("I1") = E(5)
  65.                     .Offset(i).Range("M1") = E(6)
  66.                     .Offset(i).Range("F1") = E(7)
  67.                 Next
  68.             End With
  69.         End If
  70.     End With
  71.     If Not Rng(1) Is Nothing Then
  72.     '**** 刪除"產品"重複的部分->Rng(1)
  73.         If MsgBox("刪除重複的[ID & PartNumber]", vbQuestion + vbYesNo, "產品管控清單") = vbYes Then
  74.             Rng(1).EntireRow.Delete
  75.         End If
  76.     End If
  77.    
  78.     If Not Rng(2) Is Nothing Then
  79.         '**** "產品"沒有 "物料"有 則把"物料"整欄刪除掉 -> Rng(2)
  80.         If MsgBox("刪除重複的[ID & PartNumber]", vbQuestion + vbYesNo, "物料管控清單") = vbYes Then
  81.            Rng(2).EntireRow.Delete
  82.         End If
  83.     End If
  84.     MsgBox "Ok"
  85. End Sub
複製代碼
作者: li_hsien    時間: 2014-1-21 15:24

回復 2# GBKEE

板大我發現了一點問題

我如果在產品那邊刪掉一筆

在物料那並沒有刪除掉

新增加的話還OK


最後板大幫我設置的刪除提示

為什麼刪掉後只剩下4.5筆呀???


我用2007的移除重複，並沒有這麼多重複

不知問題出在哪裡???



麻煩幫我看看

謝謝  :  )
作者: li_hsien    時間: 2014-1-21 17:48

回復 2# GBKEE

謝謝大大的幫忙

可是我發現還是沒有刪除掉耶

產品沒有的，物料那邊還是有出現

我是在產品中間隨便刪一筆測試的


那大大的重複提示

我用2007內建的移除重複測試

發現還是多刪了，可是筆數不多

我要留有重複的第一筆
EX:
A,B,C,A,A,B,C,D
我要留A,B,C,D

不知大大是不是把重複的都刪了


麻煩幫我看看  感謝  :  )
作者: li_hsien    時間: 2014-1-21 21:24

回復 2# GBKEE

版大我又出現了@@

我試了一試還是怪怪的耶

產品如果在資料中有新增

好像抓不到物料那邊

會怪怪的

還是只能在最下面新增


如果我在產品的資料中刪除一筆

物料那邊還是會出現@@

本身有2007的關係
我驗證資料重複應該剩下1026筆
物料那邊OK 不過產品那邊還是不一致


又再次麻煩大大了

謝謝你  :  )
作者: GBKEE    時間: 2014-1-22 10:33

回復 5# li_hsien
[A,B,C,A,A,B,C,D我要留A,B,C,D]
  1. d.Add AR, .Range("J" & i).Value
  2.             '****** A,B,C,A,A,B,C,D我要留A , B, C,D.. 這裡在處理.
  3.             If Err <> 0 Then                   '錯誤: 產品重複的[ID & PartNumber]
  4.                 Err.Clear
  5.                 If Rng(1) Is Nothing Then             '紀錄:產品重複的[ID & PartNumber]的位置
  6.                     Set Rng(1) = .Range("J" & i)
  7.                 Else
  8.                     Set Rng(1) = Union(.Range("J" & i), Rng(1))
  9.                 End If
  10.             End If
複製代碼
[產品沒有的，物料那邊還是有出現]
  1. '******* 我如果在產品那邊刪掉一筆,在物料那並沒有刪除掉??這裡有作處裡
  2.             If Err = 0 Then                     '物料的ID & PartNumber,有存在產品的ID & PartNumber中
  3.                 d.Remove E.Value                '除去:產品的ID & PartNumber
  4.             Else  '-> Err <> 0 有錯誤
  5.             '錯誤1:已除去產品的ID & PartNumber
  6.             '錯誤2:物料的ID & PartNumber,不存在產品的ID & PartNumber中
  7.                 If Rng(2) Is Nothing Then       '紀錄儲存格的位置
  8.                     Set Rng(2) = E
  9.                 Else
  10.                     Set Rng(2) = Union(E, Rng(2)) '紀錄儲存格的位置
  11.                 End If
  12.             End If
  13.             '*********************************************************
  14.             Err.Clear
複製代碼
請上傳測試的檔案看看
作者: li_hsien    時間: 2014-1-22 11:00

回復 6# GBKEE

我都是直接再次COPY過去

剛剛再次確認

新增應該OK

不過好像都是要按下MSGBOX確認後才可以


可是移除後數量不對

附檔還有兩張圖

一張是原有資料

另一張是用了移除重複後的資料

煩請大大幫我看看


[attach]17336[/attach]
作者: GBKEE    時間: 2014-1-22 11:58

本帖最後由 GBKEE 於 2014-1-22 12:02 編輯

回復 7# li_hsien

7#的檔案,執行2#的程式碼

找出 物料管控清單 (產品沒有或物料重複)的ID

[attach]17338[/attach]


1194同列為產品管控清單,物料管控清單的最後一筆資料

[attach]17337[/attach]

[attach]17339[/attach]
作者: li_hsien    時間: 2014-1-22 14:09

回復 8# GBKEE

板大我再測試了一下

在物料或是產品的工作表執行應該都沒有差別吧


我不太懂第一次刪除重複的動作

因為附檔的資料一開始在"產品"那邊有1801項，"物料"那邊有1206項

我先用移除重複篩一次"產品"那邊的項目，只剩下1206項

可是我用了程式跑只剩下1196項

應該是多刪了板大圖示的部分



我的處理流程是先依據"產品"裡的來產出"物料"裡面的

動作 是如果 (都是以ID & PART NUMBER為依據)
"產品"有 "物料"有  則把 "產品" 的資料COPY到 "物料" 原本的位子上
"產品"有 "物料"沒有 則把新增多出來的增加到 "物料" 最下面
"產品"沒有 "物料"有 則把"物料"整欄刪除掉

所以是以"產品"擁有的為主，不過產出"物料"之前得先刪除"產品"重複的部分

最後結果是"產品"跟"物料"的項目數會是一樣的沒有錯


不過就在一開始的移除有些問題

做過第一次動作後，我再測試刪刪減減這些動作，都很順利沒有問題   :  )



有點冗長@@

煩請板大看看

謝謝
作者: GBKEE    時間: 2014-1-22 14:30

回復 9# li_hsien
2#的程式請你修改一下看看產品管控清單重複的ID
  1. '********* "產品管控清單" 刪除重複的[ID & PartNumber]*******************
  2.     If Not Rng(1) Is Nothing Then
  3.         If MsgBox("刪除重複的[ID & PartNumber]", vbQuestion + vbYesNo, "產品管控清單") = vbYes Then           
  4.              Worksheets("產品管控清單").Activate
  5.             Stop                                            '程式會停止 按F8一步一步執行下去看工作表的情形
  6.             Rng(1).EntireRow.Select                  '選取重複的ID
  7.            MsgBox Rng(1).EntireRow.Address
  8.             Rng(1).EntireRow.Delete   '先註解掉不刪除
  9.         End If
  10.     End If
複製代碼
作者: li_hsien    時間: 2014-1-22 15:21

回復 10# GBKEE


這些是我重複的
$1806:$1810,$1800:$1802,$1798:$1798,$1794:$1795,$1791:$1792,$1788:$1789,$1785:$1785,$1772:$1772,$1764:$1764,$1754:$1758,$1748:$1750,$1743:$1743,$1739:$1740,$1736:$1737,$1733:$1734,$1730:$1730,$1718:$1718,$1710:$1710,$1698:$1701,$1691:$1691,$1688:$1689


如有重複我只要刪除重複的部分
留唯一

還是板大的程式把重複的全刪了???

我也不確定是不是

麻煩大大幫我看看

謝謝你
作者: Hsieh    時間: 2014-1-22 16:40

本帖最後由 Hsieh 於 2014-1-22 16:43 編輯

回復 1# li_hsien
  1. Sub ex()
  2. Dim Ar
  3. Set d = CreateObject("Scripting.Dictionary")
  4. With Sheets("產品管控清單")
  5. Ar = .UsedRange.Value
  6. For i = 2 To UBound(Ar, 1) '記錄產品不重覆記錄
  7.    d(Ar(i, 10)) = Array(Ar(i, 5), Ar(i, 6), Ar(i, 7), Ar(i, 8), Ar(i, 9), Ar(i, 10), Ar(i, 3), Ar(i, 1), Ar(i, 2))
  8. Next
  9. End With
  10. With Sheets("物料管控清單")
  11. Ar = .UsedRange.Value
  12. For i = 2 To UBound(Ar, 1)
  13.    If d.exists(Ar(i, 6)) Then
  14.      .Cells(i, 1).Resize(, 9) = d(Ar(i, 6)) '產品出現在物料則更新為產品資料
  15.       d.Remove Ar(i, 6) '移除已寫入的資料
  16.    End If
  17. Next
  18. '若產品未出現於物料，則新增至物料資料尾
  19. If d.Count > 0 Then .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(d.Count, 9) = Application.Transpose(Application.Transpose(d.items))
  20. End With
  21. End Sub
複製代碼
[attach]17340[/attach]
作者: li_hsien    時間: 2014-1-22 17:05

回復 12# Hsieh


謝謝H板大的解答

不過測試了一下

我發現如果我在"產品"那邊刪除一筆，再次執行

"物料"那並不會刪除耶

好像還是有點問題

麻煩板大幫我看看

謝謝:  )
作者: li_hsien    時間: 2014-1-22 18:13

回復 10# GBKEE

GB板大，如果我不做重複的處理

直接做"產品"跟"物料"的新增刪除修改

改成以下方式可行嗎???

模式一樣是以"產品"為主
如果
"產品"有   "物料"有  則把"產品"  放到  "物料" 原有的位置
"產品"無   "物料"有  則把"物料" 那筆整欄刪掉
"產品"有   "物料"無  則把新增出來的那筆"產品"資訊 新增到"物料"的最下方


但我測試幾次，如果在"產品"的表單中加入一筆新的

可能無法在"物料"中顯示

在最下端增加好像才不會出錯


麻煩板大幫我看看程式還需做怎樣的修改

謝謝你  :  )
  1. Sub Ex2()
  2.     Dim d As New Collection, AR(1 To 7), i As Integer, Rng As Range, E As Variant
  3.     On Error Resume Next              'Collection新增的KEY如被使用或有錯誤
  4.     With Worksheets("產品管控清單")
  5.         For i = 2 To .Range("J1").End(xlDown).Row
  6.             AR(1) = .Range("E" & i)             'PRODUCT ID(A)
  7.             AR(2) = .Range("F" & i)             'CHILDPARTNUMBER(B)
  8.             AR(3) = .Range("C" & i)             'MP date(G)
  9.             AR(4) = .Range("A" & i)             '週別(H)
  10.             AR(5) = .Range("B" & i)             '更新週別(I)
  11.             AR(6) = DateDiff("d", Date, AR(3))  '工作日(M)
  12.             AR(7) = .Range("J" & i)             'Product ID & PartNumber(F)
  13.             d.Add AR, .Range("J" & i).Value
  14.         Next
  15.     End With
  16.     With Worksheets("物料管控清單")
  17.         For Each E In .Range("F:F").SpecialCells(xlCellTypeConstants).Offset(1)
  18.             .Range("A" & E.Row) = d(E.Value)(1)
  19.             .Range("B" & E.Row) = d(E.Value)(2)
  20.             .Range("G" & E.Row) = d(E.Value)(3)
  21.             .Range("H" & E.Row) = d(E.Value)(4)
  22.             .Range("I" & E.Row) = d(E.Value)(5)
  23.             .Range("M" & E.Row) = d(E.Value)(6)
  24.             .Range("F" & E.Row) = d(E.Value)(7)
  25.             If Err = 0 Then                     '物料的ID & PartNumber,存在產品的ID & PartNumber中
  26.                 d.Remove E.Value                '除去:產品的ID & PartNumber

  28.             ElseIf Err <> 0 And E <> "" Then    '物料的ID & PartNumber,不存在產品的ID & PartNumber中
  29.                 If Rng Is Nothing Then       '取的儲存格的位置
  30.                     Set Rng = E
  31.                 Else
  32.                     [color=Red]Set Rng = Union(E, Rng)[/color]
  33.                     [color=Red]Rng.EntireRow.Delete[/color]
  34.                 End If
  35.             End If
  36.             Err.Clear
  37.         Next
  38.         If d.Count > 0 Then                     '補上:物料沒有的產品ID & PartNumber
  39.             i = 0
  40.             With .Range("A1").End(xlDown)
  41.                 For Each E In d
  42.                     i = i + 1
  43.                     .Offset(i).Range("A1") = E(1)
  44.                     .Offset(i).Range("B1") = E(2)
  45.                     .Offset(i).Range("G1") = E(3)
  46.                     .Offset(i).Range("H1") = E(4)
  47.                     .Offset(i).Range("I1") = E(5)
  48.                     .Offset(i).Range("M1") = E(6)
  49.                     .Offset(i).Range("F1") = E(7)
  50.                 Next
  51.             End With
  52.         End If
  53.     End With
複製代碼
作者: Hsieh    時間: 2014-1-22 21:47

回復 14# li_hsien
模式一樣是以"產品"為主
如果
"產品"有   "物料"有  則把"產品"  放到  "物料" 原有的位置
"產品"無   "物料"有  則把"物料" 那筆整欄刪掉
"產品"有   "物料"無  則把新增出來的那筆"產品"資訊 新增到"物料"的最下方

這樣不就只是把產品刪除重覆的結果而已嗎？
作者: li_hsien    時間: 2014-1-22 22:53

回復 15# Hsieh

"產品"那邊的工作表還是需要保留著

因為"產品"跟"物料"的資訊不太一樣

欄位也不盡相同

但有些部分一樣

那它主要對應的方式都是依據ID & PAERTNUMBER


對了!!!
其實跟之前H版大幫我處理的<兩工作表比對 新增修改>這篇是一樣的

只是我後來應該方便作業所以多產生了一個ID & PAERTNUMBER來比對

不需要好幾欄&起來比對


不過因為我用FOR再跑

所以資料量好大

想尋求快速的比對方式


麻煩各位大大們   謝謝  :   )
作者: GBKEE    時間: 2014-1-23 10:44

回復 16# li_hsien
11#說: 還是板大的程式把重複的全刪了???
給你驗正一下
  1. If Not Rng(1) Is Nothing Then
  2.     '**** 刪除"產品"重複的部分->Rng(1)
  3.         If MsgBox("刪除重複的[ID & PartNumber]", vbQuestion + vbYesNo, "產品管控清單") = vbYes Then
  4.             Rng(1).Interior.Color = vbGreen    '重複的標註為綠色
  5.             For Each E In Rng(1).Areas
  6.                 For i = 1 To E.Cells.Count
  7.                     Set Rng(3) = Rng(1).EntireColumn.Find(E.Cells(i), LookIn:=xlValues)
  8.                     If Application.Intersect(Rng(1), Rng(3)) Is Nothing Then
  9.                         Rng(3).Interior.Color = vbRed      '保留第一筆重複的標註紅色
  10.                     End If
  11.                 Next
  12.             Next
  13.           '  Rng(1).EntireRow.Delete  先不刪除去看看有保留在哪裡
  14.         End If
  15.     End If
複製代碼
你說:在最下端增加好像才不會出錯
程式有註解 [ 補上:物料沒有的產品ID & PartNumber ]   -> 就是最後補上的
那你想如何補上??
作者: li_hsien    時間: 2014-1-23 16:56

回復 17# GBKEE

謝謝板大再次幫我修改

我再測試一次還是會多刪除耶

以下是我用大大程式碼修改後的
  1. Option Explicit

  3. Sub Ex()
  4.     Dim d As New Collection, AR(1 To 7), i As Integer, Rng(1 To 2) As Range, E As Variant
  5.     On Error Resume Next              'Collection新增的KEY如被使用或有錯誤
  6.     With Worksheets("產品管控清單")
  7.         For i = 2 To .Range("J1").End(xlDown).Row
  8.             AR(1) = .Range("E" & i)             'PRODUCT ID(A)
  9.             AR(2) = .Range("F" & i)             'CHILDPARTNUMBER(B)
  10.             AR(3) = .Range("C" & i)             'MP date(G)
  11.             AR(4) = .Range("A" & i)             '週別(H)
  12.             AR(5) = .Range("B" & i)             '更新週別(I)
  13.             AR(6) = DateDiff("d", Date, AR(3))  '工作日(M)
  14.             AR(7) = .Range("J" & i)             'Product ID & PartNumber(F)
  15.             d.Add AR, .Range("J" & i).Value
  16.             '*****找出[產品管控清單]重複的[ID & PartNumber]  ****
  17.             If Err <> 0 Then
  18.                 Err.Clear
  19.                 If Rng(1) Is Nothing Then
  20.                     Set Rng(1) = .Range("J" & i)
  21.                 Else
  22.                     Set Rng(1) = Union(.Range("J" & i), Rng(1))
  23.                 End If
  24.             End If
  25.             '*****************************************************
  26.         Next
  27.     End With
  28.     With Worksheets("物料管控清單")
  29.         For Each E In .Range("F:F").SpecialCells(xlCellTypeConstants).Offset(1)
  30.             .Range("A" & E.Row) = d(E.Value)(1)
  31.             .Range("B" & E.Row) = d(E.Value)(2)
  32.             .Range("G" & E.Row) = d(E.Value)(3)
  33.             .Range("H" & E.Row) = d(E.Value)(4)
  34.             .Range("I" & E.Row) = d(E.Value)(5)
  35.             .Range("M" & E.Row) = d(E.Value)(6)
  36.             .Range("F" & E.Row) = d(E.Value)(7)
  37.             If Err = 0 Then                     '物料的ID & PartNumber,存在產品的ID & PartNumber中
  38.                 d.Remove E.Value                '除去:產品的ID & PartNumber
  39.             ElseIf Err <> 0 And E <> "" Then    '物料的ID & PartNumber,不存在產品的ID & PartNumber中
  40.                 If Rng(2) Is Nothing Then       '取的儲存格的位置
  41.                     Set Rng(2) = E
  42.                 Else
  43.                     Set Rng(2) = Union(E, Rng(2))
  44.                 End If
  45.             End If
  46.             Err.Clear
  47.         Next
  48.         If d.Count > 0 Then                     '補上:物料沒有的產品ID & PartNumber
  49.             i = 0
  50.             With .Range("A1").End(xlDown)
  51.                 For Each E In d
  52.                     i = i + 1
  53.                     .Offset(i).Range("A1") = E(1)
  54.                     .Offset(i).Range("B1") = E(2)
  55.                     .Offset(i).Range("G1") = E(3)
  56.                     .Offset(i).Range("H1") = E(4)
  57.                     .Offset(i).Range("I1") = E(5)
  58.                     .Offset(i).Range("M1") = E(6)
  59.                     .Offset(i).Range("F1") = E(7)
  60.                 Next
  61.             End With
  62.         End If
  63.     End With
  64.    
  65. '    '********* "產品管控清單" 刪除重複的[ID & PartNumber]*******************
  66. '    If Not Rng(1) Is Nothing Then
  67. '        If MsgBox("刪除重複的[ID & PartNumber]", vbQuestion + vbYesNo, "產品管控清單") = vbYes Then
  68. '            Rng(1).EntireRow.Delete
  69. '        End If
  70. '    End If
  71.    
  72. '    '********* "產品管控清單" 刪除重複的[ID & PartNumber]*******************
  73. '    If Not Rng(1) Is Nothing Then
  74. '        If MsgBox("刪除重複的[ID & PartNumber]", vbQuestion + vbYesNo, "產品管控清單") = vbYes Then
  75. '             Worksheets("產品管控清單").Activate
  76. '            Stop                                            '程式會停止 按F8一步一步執行下去看工作表的情形
  77. '            Rng(1).EntireRow.Select                  '選取重複的ID
  78. '            MsgBox Rng(1).EntireRow.Address
  79. '            Debug.Print Rng(1).EntireRow.Address
  80. ''            Rng(1).EntireRow.Delete   '先註解掉不刪除
  81. '        End If
  82. '    End If
  83.    
  84.    
  85.     If Not Rng(1) Is Nothing Then
  86.     '**** 刪除"產品"重複的部分->Rng(1)
  87.         If MsgBox("刪除重複的[ID & PartNumber]", vbQuestion + vbYesNo, "產品管控清單") = vbYes Then
  88.             Rng(1).Interior.Color = vbGreen    '重複的標註為綠色
  89.             For Each E In Rng(1).Areas
  90.                 For i = 1 To E.Cells.Count
  91.                     Set Rng(3) = Rng(1).EntireColumn.Find(E.Cells(i), LookIn:=xlValues)
  92.                     If Application.Intersect(Rng(1), Rng(3)) Is Nothing Then
  93.                         Rng(3).Interior.Color = vbRed      '保留第一筆重複的標註紅色
  94.                     End If
  95.                 Next
  96.             Next
  97.           '  Rng(1).EntireRow.Delete  先不刪除去看看有保留在哪裡
  98.         End If
  99.     End If
  100.    
  101.    
  102.     '********* "物料管控清單" 刪除重複的[ID & PartNumber]*******************
  103.     If Not Rng(2) Is Nothing Then
  104.         If MsgBox("刪除重複的[ID & PartNumber]", vbQuestion + vbYesNo, "物料管控清單") = vbYes Then
  105.           'Rng(2).EntireRow.Select
  106.            Rng(2).EntireRow.Delete
  107.         End If
  108.     End If
  109.     MsgBox "Ok"
  110. End Sub
複製代碼
應該是這樣改沒有錯吧


但我跑出來"產品"那邊一樣是多刪除

正常應該剩1206項但刪除後卻只剩1194項

好奇怪喔@@


大大說新增的部分

因為我的"產品"是由兩張工作表合而為一的

所以新增是分別在兩張工作表做的

所以新增的資訊可能會在"產品"的中間部分

不是在"產品"的最下方



請問大大

我能先處理刪除重複

那單純只做"產品","物料"資訊的新增刪除修改嗎???

這樣是否比較沒這麼複雜
(就去除掉排除重複的步驟，其餘都一樣)



以上 麻煩大大  參酌  謝謝  :   )
作者: li_hsien    時間: 2014-1-23 20:50

回復 17# GBKEE

大大你也太神奇了

真的100筆以下就OK耶@@

為什麼會這樣啊


不過我不能只有這麼幾筆

不知能否克服???
作者: GBKEE    時間: 2014-1-24 08:39

回復 19# li_hsien

   
正常應該剩1206項但刪除後卻只剩1194項,好奇怪喔@@


C欄日期格式不對導致的!!!

[attach]17352[/attach]
作者: li_hsien    時間: 2014-1-24 11:19

回復 20# GBKEE

真的是這個錯誤耶!!!!



我以為有了On Error Resume Next就可以排除了@@

不過資料增加和刪除的部分有辦法修正嗎????

因為可能從"產品"的資訊中間新增或刪除，而不是在下方

可是現在測試的結果，如果在中間新增會有錯誤，新增不到的問題


感謝大大的發現  !!!!!!!
作者: GBKEE    時間: 2014-1-25 12:10

回復 21# li_hsien
試試看
9#所說: 最後結果是"產品"跟"物料"的項目數會是一樣的沒有錯
  1. Option Explicit
  2. Sub Ex()
  3.     Dim d As New Collection, AR(), i As Integer, Rng As Range ', e As Variant
  4.     On Error Resume Next              'Collection新增的KEY如被使用或有錯誤
  5.     With Worksheets("產品管控清單")
  6.         For i = 2 To .Range("J1").End(xlDown).Row
  7.             AR = Application.Transpose(Application.Transpose(.Range("A" & i).Resize(, 10)))
  8.             '******  產品(A:J)欄位資料導入陣列  ****
  9.             '1:產品欄位週別 ,2'產品欄:更新週別,3:MP date,4:產品類別,5:PRODUCT ID,
  10.             '6:CHILDPARTNUMBER,7:CHILD_DESCRIPTION,8:Maker,9:MAKER & CODE.10:ID & PartNumber
  11.             d.Add AR, .Range("J" & i)     '
  12.             '*****找出[產品管控清單]重複的[ID & PartNumber]  ****
  13.             If Err <> 0 Then
  14.                 If Rng Is Nothing Then
  15.                     Set Rng = .Range("J" & i)
  16.                 Else
  17.                     Set Rng = Union(.Range("J" & i), Rng)
  18.                 End If
  19.             End If
  20.             Err.Clear
  21.             '*****************************************************
  22.         Next
  23.     End With
  24.     On Error GoTo 0              '不再處裡程式的錯誤
  25.     If Not Rng Is Nothing Then Rng.EntireRow.Delete
  26.     With Worksheets("物料管控清單")
  27.         .UsedRange.Offset(1).Clear
  28.         For i = 1 To d.Count
  29.             With .Range("A" & i + 1)
  30.              '產品欄位
  31.              '1:產品欄位週別 ,2'產品欄:更新週別,3:MP date,4:產品類別,5:PRODUCT ID,
  32.              '6:CHILDPARTNUMBER,7:CHILD_DESCRIPTION,8:Maker,9:MAKER & CODE.10:ID & PartNumber
  33.                 .Range("A1") = d(i)(5)   '導入物品欄位A1-M1
  34.                 .Range("B1") = d(i)(6)
  35.                 .Range("C1") = d(i)(7)
  36.                 .Range("D1") = d(i)(8)
  37.                 .Range("E1") = d(i)(9)
  38.                 .Range("F1") = d(i)(10)
  39.                 .Range("G1") = Format(d(i)(3), "YYYY/M/D")
  40.                 .Range("H1") = d(i)(2)
  41.                 .Range("I1") = d(i)(1)
  42.                 .Range("M1") = DateDiff("d", Date, .Range("G1"))  '工作日(M)
  43.             End With
  44.         Next
  45.     End With
  46.     MsgBox d.Count & "項 OK"
  47. End Sub
複製代碼
作者: li_hsien    時間: 2014-1-25 22:55

回復 22# GBKEE

新增修改正常了

感謝版大不厭其煩的熱心幫助  :  )



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