返回列表 上一主題 發帖

[發問] 如何利用核取方塊做數量加總計算

Hsieh

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

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
1# 跳轉到 »
發表於 2012-4-21 08:58 | 顯示全部帖子
回復 1# luke
按鈕執行此程式
  1. Sub ex()
  2. Dim sp As Shape, A As Range
  3. Set d = CreateObject("Scripting.Dictionary")
  4. With sheet1
  5. For Each sp In .Shapes
  6. If sp.Name Like "Check*" Then
  7.   If sp.OLEFormat.Object.Value = 1 Then d(sp.OLEFormat.Object.Caption) = 0
  8. End If
  9. Next
  10. For Each A In .Range(.[A10], .[A10].End(xlDown))
  11. If d.exists(A.Value) = True Then d(A.Offset(, 1) & A.Offset(, 2)) = A.Offset(, 3)
  12. Next
  13. End With
  14. With sheet2
  15. For Each A In .Range(.[A2], .[A2].End(xlDown))
  16. A.Offset(, 3) = A.Offset(, 2) + d(A & A.Offset(, 1))
  17. Next
  18. End With
  19. End Sub
複製代碼
學海無涯_不恥下問

TOP

Hsieh

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

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

無解，sheet2並不分區域，除非在sheet2增加區域欄位
學海無涯_不恥下問

TOP

Hsieh

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

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
3#
發表於 2012-4-21 15:33 | 顯示全部帖子
回復 8# luke
  1. Sub ex()
  2. Dim sp As Shape, A As Range
  3. Set d = CreateObject("Scripting.Dictionary")
  4. With sheet1
  5. For Each sp In .Shapes
  6. If sp.Name Like "Check*" Then
  7.   If sp.OLEFormat.Object.Value = 1 Then d(sp.OLEFormat.Object.Caption) = 0
  8. End If
  9. Next
  10. For Each A In .Range(.[A10], .[A10].End(xlDown))
  11. If d.exists(A.Value) = True Then d(A.Offset(, 1) & A.Offset(, 2)) = d(A.Offset(, 1) & A.Offset(, 2)) + A.Offset(, 3)
  12. Next
  13. End With
  14. With sheet2
  15. For Each A In .Range(.[A2], .[A2].End(xlDown))
  16. A.Offset(, 4) = A.Offset(, 2) + d(A & A.Offset(, 1))
  17. Next
  18. End With
  19. End Sub
複製代碼
學海無涯_不恥下問

TOP

Hsieh

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

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
4#
發表於 2012-4-21 19:34 | 顯示全部帖子
回復 12# luke
  1. Sub ex()
  2. Dim sp As Shape, A As Range
  3. Set d = CreateObject("Scripting.Dictionary")
  4. Set d1 = CreateObject("Scripting.Dictionary")

  6. With sheet1
  7. For Each sp In .Shapes
  8. If sp.Name Like "Check*" Then
  9.   If sp.OLEFormat.Object.Value = 1 Then d(sp.OLEFormat.Object.Caption) = 0
  10. End If
  11. Next
  12. For Each A In .Range(.[A10], .[A10].End(xlDown))
  13. If d.exists(A.Value) = True Then d1(A.Offset(, 1) & "," & A.Offset(, 2)) = d1(A.Offset(, 1) & "," & A.Offset(, 2)) + A.Offset(, 3)
  14. Next
  15. End With
  16. With sheet2
  17. For Each A In .Range(.[A2], .[A2].End(xlDown))
  18.   A.Offset(, 3) = A.Offset(, 2) + d1(A & "," & A.Offset(, 1))
  19.   d1.Remove A & "," & A.Offset(, 1)
  20. Next
  21. For Each ky In d1.keys
  22.   Set A = .Cells(.Rows.Count, 1).End(xlUp).Offset(1)
  23.   A.Resize(, 2) = Split(ky, ","): A.Offset(, 3) = d1(ky)
  24. Next
  25. End With
  26. End Sub
複製代碼
學海無涯_不恥下問

TOP

Hsieh

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

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
5#
發表於 2012-4-24 08:53 | 顯示全部帖子
回復 15# luke
  1. Sub ex()
  2. Dim Mystr$, A As Range
  3. Set d = CreateObject("Scripting.Dictionary")
  4. With sheet1
  5. For Each sp In .Shapes
  6. If sp.Name Like "Check*" Then
  7.   If sp.OLEFormat.Object.Value = 1 Then Mystr = Mystr & "," & sp.OLEFormat.Object.Caption
  8. End If
  9. Next
  10. For Each A In .Range(.[A10], .[A10].End(xlDown))
  11. k = Asc(A.Offset(, 5)) - 63
  12.   If InStr(Mystr, A) > 0 Then
  13.     d(k & "," & A.Offset(, 1) & "," & A.Offset(, 2)) = d(k & "," & A.Offset(, 1) & "," & A.Offset(, 2)) + A.Offset(, 3)
  14.   End If
  15. Next
  16. End With

  18. For i = 2 To 4
  19. With Sheets(i)
  20. For Each A In .Range(.[A2], .[A2].End(xlDown))
  21.    A.Offset(, 3) = A.Offset(, 2) + d(i & "," & A & "," & A.Offset(, 1))
  22.    d.Remove i & "," & A & "," & A.Offset(, 1)
  23. Next
  24. End With
  25. Next
  26. For Each ky In d.keys
  27. ar = Split(ky, ",")
  28. With Sheets(CInt(ar(0)))
  29. Set A = .[A1].End(xlDown).Offset(1, 0)
  30. A = ar(1): A.Offset(, 1) = ar(2): A.Offset(, 3) = d(ky)
  31. End With
  32. Next
  33. End Sub
複製代碼
學海無涯_不恥下問

TOP

Hsieh

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

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
6#
發表於 2012-4-24 17:36 | 顯示全部帖子
回復 19# luke
  1. Sub ex()
  2. Dim Mystr$, A As Range
  3. Set d = CreateObject("Scripting.Dictionary")
  4. With sheet1
  5. For Each sp In .Shapes
  6. If sp.Name Like "Check*" Then
  7.   If sp.OLEFormat.Object.Value = 1 Then Mystr = Mystr & "," & sp.OLEFormat.Object.Caption
  8. End If
  9. Next
  10. For Each A In .Range(.[A10], .Cells(.Rows.Count, 1).End(xlUp))
  11. k = Asc(A.Offset(, 5)) - 63
  12.   If InStr(Mystr, A) > 0 Then
  13.     d(k & "," & A.Offset(, 1) & "," & A.Offset(, 2)) = d(k & "," & A.Offset(, 1) & "," & A.Offset(, 2)) + A.Offset(, 3)
  14.   End If
  15. Next
  16. End With

  18. For i = 2 To 4
  19. With Sheets(i)
  20. If Application.CountA(.Columns("A")) > 0 Then
  21. For Each A In .Range(.[A2], .Cells(.Rows.Count, 2).End(xlUp))
  22.    A.Offset(, 3) = A.Offset(, 2) + d(i & "," & A & "," & A.Offset(, 1))
  23.    d.Remove i & "," & A & "," & A.Offset(, 1)
  24. Next
  25. End If
  26. End With
  27. Next
  28. For Each ky In d.keys
  29. ar = Split(ky, ",")
  30. With Sheets(CInt(ar(0)))
  31. Set A = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
  32. A = ar(1): A.Offset(, 1) = ar(2): A.Offset(, 3) = d(ky)
  33. End With
  34. Next
  35. End Sub
複製代碼
學海無涯_不恥下問

TOP

Hsieh

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

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
7#
發表於 2012-4-25 10:08 | 顯示全部帖子
回復 25# luke
  1. Sub ex()
  2. Dim Mystr$, A As Range
  3. Set d = CreateObject("Scripting.Dictionary")
  4. With sheet1
  5. For Each sp In .Shapes
  6. If sp.Name Like "Check*" Then
  7.   If sp.OLEFormat.Object.Value = 1 Then Mystr = Mystr & "," & sp.OLEFormat.Object.Caption
  8. End If
  9. Next
  10. For Each A In .Range(.[A10], .Cells(.Rows.Count, 1).End(xlUp))  這邊Cells(.Rows.Count, 2)改成Cells(.Rows.Count, 1)
  11. k = Asc(A.Offset(, 5)) - 63
  12.   If InStr(Mystr, A) > 0 Then
  13.     d(k & "," & A.Offset(, 1) & "," & A.Offset(, 2)) = d(k & "," & A.Offset(, 1) & "," & A.Offset(, 2)) + A.Offset(, 3)
  14.   End If
  15. Next
  16. End With

  18. For i = 2 To 4
  19. With Sheets(i)
  20. If Application.CountA(.Columns("A")) > 0 Then
  21. For Each A In .Range(.[A2], .Cells(.Rows.Count, 1).End(xlUp))
  22.    A.Offset(, 3) = A.Offset(, 2) + d(i & "," & A & "," & A.Offset(, 1))
  23.    d.Remove i & "," & A & "," & A.Offset(, 1)
  24. Next
  25. End If
  26. End With
  27. Next
  28. For Each ky In d.keys
  29. ar = Split(ky, ",")
  30. With Sheets(CInt(ar(0)))
  31. Set A = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
  32. A = ar(1): A.Offset(, 1) = ar(2): A.Offset(, 3) = d(ky)
  33. End With
  34. Next
  35. End Sub
複製代碼
學海無涯_不恥下問

TOP

Hsieh

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

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
8#
發表於 2012-4-25 10:22 | 顯示全部帖子
回復 21# luke

這個錯誤是來自Application.Caller
必須以勾選核取方塊驅動程式
不能直接執行巨集
學海無涯_不恥下問

TOP

        靜思自在 : 忘功不忘過，忘怨不忘恩。
返回列表 上一主題