發問∶請各位高手指導修正

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

1^# 跳轉到 »

發表於 2014-1-25 08:07 | 顯示全部帖子

回復 1# eric093
試試看

Option Explicit
Sub aa()
Dim Rng(1 To 4), E As Range
Set Rng(1) = Sheets(1).Range("A2")
'Set Rng(2) = Sheets(1).Range("G:G") '範圍大(整欄)相對跑迴圈時間長
Set Rng(2) = Sheets(1).Range("G2", Sheets(1).Range("G2").End(xlDown)) '範圍小(有資料的整欄)
Do While Rng(1) <> ""
Set Rng(3) = Rng(2).Find(Rng(1), lookat:=xlWhole)
If Not Rng(3) Is Nothing Then
For Each E In Rng(2) '所有客戶編號中跑迴圈
If Rng(1) = E And Rng(1).Offset(, 3) = E.Offset(, 1) Then '下單者相同
Rng(1).Offset(, 4).Value = E.Offset(, 2)
End If
Next
End If
Set Rng(1) = Rng(1).Offset(1)
Loop
End Sub
Sub Ex()
Dim Rng(1 To 3) As Range, E As Range
Set Rng(1) = Sheets(1).Range("A2")
Set Rng(2) = Sheets(1).Range("G:G")
Do While Rng(1) <> ""
Set Rng(3) = Rng(2).Find(Rng(1), lookat:=xlWhole)
If Not Rng(3) Is Nothing Then
With Rng(2)
.Replace Rng(1), "=5/0" '相同客戶編號更換為錯誤值
With .SpecialCells(xlCellTypeFormulas, xlErrors) '錯誤值的範圍
For Each E In .Cells '僅相同客戶編號中跑迴圈
If E.Offset(, 1) = Rng(1).Offset(, 3) Then Rng(1).Offset(, 4) = E.Offset(, 2)
'下單者相同
Next
.Value = Rng(1) '錯誤值改回為客戶編號
End With
End With
End If
Set Rng(1) = Rng(1).Offset(1)
Loop
End Sub

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

靜思自在 : 一個缺口的杯子，如果換一個角度看它，它仍然是圓的。