- 帖子
- 248
- 主題
- 55
- 精華
- 0
- 積分
- 314
- 點名
- 54
- 作業系統
- XP / WIN7
- 軟體版本
- 2003 / 2007
- 閱讀權限
- 20
- 性別
- 男
- 來自
- Tainan
- 註冊時間
- 2013-10-18
- 最後登錄
- 2025-3-13
            
|
回復 17# GBKEE
謝謝板大再次幫我修改
我再測試一次還是會多刪除耶
以下是我用大大程式碼修改後的- Option Explicit
- Sub Ex()
- Dim d As New Collection, AR(1 To 7), i As Integer, Rng(1 To 2) As Range, E As Variant
- On Error Resume Next 'Collection新增的KEY如被使用或有錯誤
- With Worksheets("產品管控清單")
- For i = 2 To .Range("J1").End(xlDown).Row
- AR(1) = .Range("E" & i) 'PRODUCT ID(A)
- AR(2) = .Range("F" & i) 'CHILDPARTNUMBER(B)
- AR(3) = .Range("C" & i) 'MP date(G)
- AR(4) = .Range("A" & i) '週別(H)
- AR(5) = .Range("B" & i) '更新週別(I)
- AR(6) = DateDiff("d", Date, AR(3)) '工作日(M)
- AR(7) = .Range("J" & i) 'Product ID & PartNumber(F)
- d.Add AR, .Range("J" & i).Value
- '*****找出[產品管控清單]重複的[ID & PartNumber] ****
- If Err <> 0 Then
- Err.Clear
- If Rng(1) Is Nothing Then
- Set Rng(1) = .Range("J" & i)
- Else
- Set Rng(1) = Union(.Range("J" & i), Rng(1))
- End If
- End If
- '*****************************************************
- Next
- End With
- With Worksheets("物料管控清單")
- For Each E In .Range("F:F").SpecialCells(xlCellTypeConstants).Offset(1)
- .Range("A" & E.Row) = d(E.Value)(1)
- .Range("B" & E.Row) = d(E.Value)(2)
- .Range("G" & E.Row) = d(E.Value)(3)
- .Range("H" & E.Row) = d(E.Value)(4)
- .Range("I" & E.Row) = d(E.Value)(5)
- .Range("M" & E.Row) = d(E.Value)(6)
- .Range("F" & E.Row) = d(E.Value)(7)
- If Err = 0 Then '物料的ID & PartNumber,存在產品的ID & PartNumber中
- d.Remove E.Value '除去:產品的ID & PartNumber
- ElseIf Err <> 0 And E <> "" Then '物料的ID & PartNumber,不存在產品的ID & PartNumber中
- If Rng(2) Is Nothing Then '取的儲存格的位置
- Set Rng(2) = E
- Else
- Set Rng(2) = Union(E, Rng(2))
- End If
- End If
- Err.Clear
- Next
- If d.Count > 0 Then '補上:物料沒有的產品ID & PartNumber
- i = 0
- With .Range("A1").End(xlDown)
- For Each E In d
- i = i + 1
- .Offset(i).Range("A1") = E(1)
- .Offset(i).Range("B1") = E(2)
- .Offset(i).Range("G1") = E(3)
- .Offset(i).Range("H1") = E(4)
- .Offset(i).Range("I1") = E(5)
- .Offset(i).Range("M1") = E(6)
- .Offset(i).Range("F1") = E(7)
- Next
- End With
- End If
- End With
-
- ' '********* "產品管控清單" 刪除重複的[ID & PartNumber]*******************
- ' If Not Rng(1) Is Nothing Then
- ' If MsgBox("刪除重複的[ID & PartNumber]", vbQuestion + vbYesNo, "產品管控清單") = vbYes Then
- ' Rng(1).EntireRow.Delete
- ' End If
- ' End If
-
- ' '********* "產品管控清單" 刪除重複的[ID & PartNumber]*******************
- ' If Not Rng(1) Is Nothing Then
- ' If MsgBox("刪除重複的[ID & PartNumber]", vbQuestion + vbYesNo, "產品管控清單") = vbYes Then
- ' Worksheets("產品管控清單").Activate
- ' Stop '程式會停止 按F8一步一步執行下去看工作表的情形
- ' Rng(1).EntireRow.Select '選取重複的ID
- ' MsgBox Rng(1).EntireRow.Address
- ' Debug.Print Rng(1).EntireRow.Address
- '' Rng(1).EntireRow.Delete '先註解掉不刪除
- ' End If
- ' End If
-
-
- If Not Rng(1) Is Nothing Then
- '**** 刪除"產品"重複的部分->Rng(1)
- If MsgBox("刪除重複的[ID & PartNumber]", vbQuestion + vbYesNo, "產品管控清單") = vbYes Then
- Rng(1).Interior.Color = vbGreen '重複的標註為綠色
- For Each E In Rng(1).Areas
- For i = 1 To E.Cells.Count
- Set Rng(3) = Rng(1).EntireColumn.Find(E.Cells(i), LookIn:=xlValues)
- If Application.Intersect(Rng(1), Rng(3)) Is Nothing Then
- Rng(3).Interior.Color = vbRed '保留第一筆重複的標註紅色
- End If
- Next
- Next
- ' Rng(1).EntireRow.Delete 先不刪除去看看有保留在哪裡
- End If
- End If
-
-
- '********* "物料管控清單" 刪除重複的[ID & PartNumber]*******************
- If Not Rng(2) Is Nothing Then
- If MsgBox("刪除重複的[ID & PartNumber]", vbQuestion + vbYesNo, "物料管控清單") = vbYes Then
- 'Rng(2).EntireRow.Select
- Rng(2).EntireRow.Delete
- End If
- End If
- MsgBox "Ok"
- End Sub
但我跑出來"產品"那邊一樣是多刪除
正常應該剩1206項但刪除後卻只剩1194項
好奇怪喔@@
大大說新增的部分
因為我的"產品"是由兩張工作表合而為一的
所以新增是分別在兩張工作表做的
所以新增的資訊可能會在"產品"的中間部分
不是在"產品"的最下方
請問大大
我能先處理刪除重複
那單純只做"產品","物料"資訊的新增刪除修改嗎???
這樣是否比較沒這麼複雜
(就去除掉排除重複的步驟，其餘都一樣)
以上 麻煩大大 參酌 謝謝 : ) |
|
發表於 2014-1-23 16:56
| 
