返回列表 上一主題 發帖

請問可否做到自動扣減資料

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
137  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2025-6-7 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
1# 跳轉到 »
發表於 2012-12-6 16:03 | 顯示全部帖子
  1. Sub ex()
  2. Set d = CreateObject("Scripting.Dictionary")
  3. ay = Array("OBL", "OHC", "CO")
  4. With Sheets("Sheet1")
  5. Set rng = .Range(.[C2], .Cells(.Rows.Count, 3).End(xlUp))
  6. For Each a In rng
  7.   If IsEmpty(d(a.Value)) Then
  8.   For i = 9 To 11
  9.   Set rng1 = .Cells(2, i).Resize(rng.Rows.Count, 1)
  10.   Set rng2 = .Cells(2, i + 6).Resize(rng.Rows.Count, 1)
  11.      x = Evaluate("SumProduct((" & rng.Address & "=" & a & ")*(" & rng1.Address & "<>""""))")
  12.      y = Evaluate("SumProduct((" & rng.Address & "=" & a & ")*(" & rng2.Address & "<>""""))")
  13.      If x = 0 Xor y = 0 Then mystr = IIf(mystr = "", ay(i - 9), mystr & "," & ay(i - 9))
  14.   Next
  15.   If mystr <> "" Then d(a.Value) = Array(a.Value, a.Offset(, 1).Value, a.Offset(, 2).Value, a.Offset(, 3).Value, mystr) Else d.Remove a.Value
  16.   mystr = ""
  17.   End If
  18. Next
  19. End With
  20. With Sheets("ON HAND")
  21. .UsedRange.Offset(1).ClearContents
  22. .[A2].Resize(d.Count, 5) = Application.Transpose(Application.Transpose(d.items))
  23. End With
  24. End Sub
複製代碼
回復 7# 198188
學海無涯_不恥下問

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
137  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2025-6-7 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
2#
發表於 2012-12-6 17:49 | 顯示全部帖子
回復 9# 198188

應該是你的作用中工作表並非Sheet1
那就公式內參照加上工作表
  1. Sub ex()
  2. Set d = CreateObject("Scripting.Dictionary")
  3. ay = Array("OBL", "OHC", "CO")
  4. With Sheets("Sheet1")
  5. Set Rng = .Range(.[C2], .Cells(.Rows.Count, 3).End(xlUp))
  6. For Each a In Rng
  7.   If IsEmpty(d(a.Value)) Then
  8.   For i = 9 To 11
  9.   Set rng1 = .Cells(2, i).Resize(Rng.Rows.Count, 1)
  10.   Set rng2 = .Cells(2, i + 6).Resize(Rng.Rows.Count, 1)
  11.      x = Evaluate("SumProduct((" & Rng.Address(, , , 1) & "=" & a & ")*(" & rng1.Address(, , , 1) & "<>""""))")  '參照位址包含外部參照
  12.      y = Evaluate("SumProduct((" & Rng.Address(, , , 1) & "=" & a & ")*(" & rng2.Address(, , , 1) & "<>""""))")  '參照位址包含外部參照
  13.      If x = 0 Xor y = 0 Then mystr = IIf(mystr = "", ay(i - 9), mystr & "," & ay(i - 9))
  14.   Next
  15.   If mystr <> "" Then d(a.Value) = Array(a.Value, a.Offset(, 1).Value, a.Offset(, 2).Value, a.Offset(, 3).Value, mystr) Else d.Remove a.Value
  16.   mystr = ""
  17.   End If
  18. Next
  19. End With
  20. With Sheets("ON HAND")
  21. .UsedRange.Offset(1).ClearContents
  22. If d.Count > 0 Then .[A2].Resize(d.Count, 5) = Application.Transpose(Application.Transpose(d.items))
  23. End With
  24. End Sub
複製代碼
學海無涯_不恥下問

TOP

        靜思自在 : 閒人無樂趣，忙人無是非。
返回列表 上一主題