返回列表 上一主題 發帖

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

回復 20# GBKEE


   回覆G大

該檔是直接呼叫巨集執行
如附檔說明
TEST13-1.gif

TOP

回復 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

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

TOP

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

回復 21# luke
我 2# 有寫   將所有的核取方塊 指定巨集 為此程序
每一個 核取方塊 都須  指定巨集 為此程序  然後 按下  核取方塊 會執行這 程序 試試看

TOP

回復 23# GBKEE


    回覆G大

     將sheet1表每個核取方塊指定巨集後
     執行該巨集時仍會出問題如下說明:
    TEST13-3.gif

TOP

回復 22# Hsieh


    謝謝H大

     sheet1表巨集執行後
     sheet2表至sheet4表多出了E欄(數量重覆)
     如粉紅色區
TEST13E.rar (32.75 KB)

TOP

回復 24# luke
xlWord As String   刪掉 As String   再試看看

TOP

回復 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

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

TOP

回復 21# luke

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

TOP

        靜思自在 : 【蒙蔽的自由】人常在什麼都可以自由自在的時候,卻被這種隨心所欲的自由蒙蔽,虛擲時光而毫無覺知。
返回列表 上一主題