Board logo

標題: [發問] 如何利用核取方塊做數量加總計算 [打印本頁]
作者: luke    時間: 2012-4-21 01:12     標題: 如何利用核取方塊做數量加總計算

本帖最後由 luke 於 2012-4-21 09:08 編輯

各位大大

小第想利用sheet1表4個核取方塊作選單選擇, 當代碼A01-D01小方塊有被勾選,

該代碼全部所對應區域的料號顯示數量要與sheet2表相同料號的數量做加總計算.

煩請先進 大大指導
[attach]10552[/attach]
作者: GBKEE    時間: 2012-4-21 06:16

本帖最後由 GBKEE 於 2012-4-21 06:33 編輯

回復 1# luke
將所有的核取方塊 指定巨集 為此程序
  1. Option Explicit
  2. Sub Ex()
  3.     Dim D As Object, 區域 As String, E, Check As Object
  4.     Set D = CreateObject("Scripting.Dictionary")
  5.     With sheet1
  6.         Set Check = ActiveSheet.Shapes(Application.Caller).OLEFormat.Object '選取的 核取方塊
  7.         區域 = Check.Caption                                                '核取方塊的標題文字
  8.         For Each E In .Range("A9").CurrentRegion.Columns(1).Cells
  9.                 If E = 區域 Then D(E.Cells(1, 2) & E.Cells(1, 3)) = E.Cells(1, 4)
  10.         Next
  11.     End With
  12.     With sheet2
  13.         For Each E In .Range("A1").CurrentRegion.Columns(1).Cells
  14.             If Check.Value=1 Then
  15.                 If D(E & E.Cells(1, 2)) <> "" Then E.Cells(1, 4) = D(E & E.Cells(1, 2)) + E.Cells(1, 3)
  16.             Else
  17.                 If D(E & E.Cells(1, 2)) <> "" Then E.Cells(1, 4) = E.Cells(1, 3)
  18.             End If
  19.         Next
  20.     End With
  21. End Sub
複製代碼
作者: Hsieh    時間: 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
複製代碼
作者: luke    時間: 2012-4-21 11:56

回復 2# GBKEE


    謝謝GBKEE 版大

     執行至第7列
     區域 = Check.Caption

     顯示"型態不符合"錯誤
作者: luke    時間: 2012-4-21 11:57

回復 3# Hsieh

    謝謝H大

    若A01-D01代碼顯示區域有相同的料號時,
    應如何避免相加的錯誤如黃色資料列所示

     煩請先進 大大指導
    [attach]10554[/attach]
作者: Hsieh    時間: 2012-4-21 12:41

回復 5# luke

無解，sheet2並不分區域，除非在sheet2增加區域欄位
作者: GBKEE    時間: 2012-4-21 14:40

回復 4# luke
執行5# 的檔案 並沒有錯誤發生
作者: luke    時間: 2012-4-21 15:01

回復 6# Hsieh


    謝謝H大

    如sheet1表E欄給了判斷, 再將勾選後的結果
    整理至sheet1表G:I欄如修正數量所示
   
     請問如何與sheet2表相對應的料號做加總

      煩請先進 大大指導
      [attach]10560[/attach]
作者: luke    時間: 2012-4-21 15:22

回復 7# GBKEE


    謝謝GBKEE 回覆

     F8逐步執行後顯示"型態不符合"錯誤
     [attach]10561[/attach]
作者: Hsieh    時間: 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
複製代碼
作者: GBKEE    時間: 2012-4-21 15:46

回復 9# luke
會是 2007 版 不接受變數用中文設定嗎?
請你將 "區域" 這中文變數 改成 英文 "xlWord" 試試看
作者: luke    時間: 2012-4-21 18:50

回復 10# Hsieh

謝謝H大
   
若sheet1表核取方塊中多了代碼E001和代碼D01有新增的料號名稱
如D0012, E0001和E0002並不存在sheet1表中時

如何將這些新增料號/名稱/數量
做勾選加總時,一併轉到sheet2表內

煩請先進 大大指導
[attach]10566[/attach]
作者: Hsieh    時間: 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
複製代碼
作者: luke    時間: 2012-4-23 21:29

回復 11# GBKEE


    回覆G大

    將 "區域" 這中文變數 改成 英文 "xlWord" 仍無法結決


     以上
作者: luke    時間: 2012-4-23 21:37

[attach]10616[/attach]回復 13# Hsieh

謝謝 H大

sheet1表F欄示新增作sheet表判斷
代碼A=sheet2表
代碼B=sheet3表
代碼C=sheet4表

當勾選核取方塊後, 想從sheet1表F欄所對應的代碼,
同時對sheet2表,sheet3表和sheet4表
進行合併加總並將該料號/名稱的數量
以紅色標示如各表所示位置

煩請先進 大大指導
[attach]10616[/attach]
作者: GBKEE    時間: 2012-4-24 06:14

回復 14# luke
可否將套用我的程序檔案上傳看看
作者: Hsieh    時間: 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
複製代碼
作者: luke    時間: 2012-4-24 14:16

回復 16# GBKEE


    回!覆G大

     原碼程式檔含錄製的GIF動畫如附件
      [attach]10626[/attach]
作者: luke    時間: 2012-4-24 14:17

回復 17# Hsieh

謝謝H大

當sheet2表至 sheet4表任一工作表中A:C欄為空白欄時, 強制執行動作時間度長如上圖sheeet4表是一張空白工作表時, 電腦是否能夠判斷去顯示該sheet4表為空白表格並給予提示信息如"目前sheeet4表空白無資料".

原程式段結束前, 小弟加了sheet2表至sheet4表料號名稱的數量不相等時該數字以紅色標示, 是否可以簡化程式?

如何防止sheet2表至sheet4表空白錯誤和簡化數量不相同時用紅色標示出來?
[attach]10627[/attach]
作者: GBKEE    時間: 2012-4-24 15:52

回復 18# luke
請問 那些控制項 你有 將 巨集 指定到這程序嗎?
如圖 　

[attach]10631[/attach]
作者: luke    時間: 2012-4-24 16:33

回復 20# GBKEE


   回覆G大

該檔是直接呼叫巨集執行
如附檔說明
[attach]10632[/attach]
作者: Hsieh    時間: 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
複製代碼
作者: GBKEE    時間: 2012-4-24 19:33

本帖最後由 GBKEE 於 2012-4-25 10:24 編輯

回復 21# luke
我 2# 有寫   將所有的核取方塊 指定巨集 為此程序
每一個 核取方塊 都須  指定巨集 為此程序  然後 按下  核取方塊 會執行這 程序 試試看
作者: luke    時間: 2012-4-24 23:32

回復 23# GBKEE


    回覆G大

     將sheet1表每個核取方塊指定巨集後
     執行該巨集時仍會出問題如下說明:
    [attach]10643[/attach]
作者: luke    時間: 2012-4-24 23:35

回復 22# Hsieh


    謝謝H大

     sheet1表巨集執行後
     sheet2表至sheet4表多出了E欄(數量重覆)
     如粉紅色區
[attach]10645[/attach]
作者: GBKEE    時間: 2012-4-25 07:32

回復 24# luke
xlWord As String   刪掉 As String   再試看看
作者: Hsieh    時間: 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
複製代碼
作者: Hsieh    時間: 2012-4-25 10:22

回復 21# luke

這個錯誤是來自Application.Caller
必須以勾選核取方塊驅動程式
不能直接執行巨集



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