luke

中學生 Rank: 2

帖子: 140
主題: 37
精華: 0
積分: 193
點名: 0
作業系統: Windows XP
軟體版本: Office 2007
閱讀權限: 20
註冊時間: 2012-3-28
最後登錄: 2015-7-5

2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章

1^# 跳轉到 » 倒序看帖

打印

字體大小: tT

發表於 2012-4-21 01:12 | 只看該作者

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

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

各位大大

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

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

煩請先進大大指導

TEST13.rar (33.86 KB)

樓主熱帖

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

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

2^#

發表於 2012-4-21 06:16 | 只看該作者

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

回復 1# luke
將所有的核取方塊指定巨集為此程序

Option Explicit
Sub Ex()
Dim D As Object, 區域 As String, E, Check As Object
Set D = CreateObject("Scripting.Dictionary")
With sheet1
Set Check = ActiveSheet.Shapes(Application.Caller).OLEFormat.Object '選取的核取方塊
區域 = Check.Caption '核取方塊的標題文字
For Each E In .Range("A9").CurrentRegion.Columns(1).Cells
If E = 區域 Then D(E.Cells(1, 2) & E.Cells(1, 3)) = E.Cells(1, 4)
Next
End With
With sheet2
For Each E In .Range("A1").CurrentRegion.Columns(1).Cells
If Check.Value=1 Then
If D(E & E.Cells(1, 2)) <> "" Then E.Cells(1, 4) = D(E & E.Cells(1, 2)) + E.Cells(1, 3)
Else
If D(E & E.Cells(1, 2)) <> "" Then E.Cells(1, 4) = E.Cells(1, 3)
End If
Next
End With
End Sub

複製代碼

TOP

Hsieh

超級版主 Rank: 8 Rank: 8

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

2024年全勤獎章 2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

3^#

發表於 2012-4-21 08:58 | 只看該作者

回復 1# luke
按鈕執行此程式

Sub ex()
Dim sp As Shape, A As Range
Set d = CreateObject("Scripting.Dictionary")
With sheet1
For Each sp In .Shapes
If sp.Name Like "Check*" Then
If sp.OLEFormat.Object.Value = 1 Then d(sp.OLEFormat.Object.Caption) = 0
End If
Next
For Each A In .Range(.[A10], .[A10].End(xlDown))
If d.exists(A.Value) = True Then d(A.Offset(, 1) & A.Offset(, 2)) = A.Offset(, 3)
Next
End With
With sheet2
For Each A In .Range(.[A2], .[A2].End(xlDown))
A.Offset(, 3) = A.Offset(, 2) + d(A & A.Offset(, 1))
Next
End With
End Sub

複製代碼

學海無涯_不恥下問

TOP

luke

中學生 Rank: 2

帖子: 140
主題: 37
精華: 0
積分: 193
點名: 0
作業系統: Windows XP
軟體版本: Office 2007
閱讀權限: 20
註冊時間: 2012-3-28
最後登錄: 2015-7-5

2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章

4^#

發表於 2012-4-21 11:56 | 只看該作者

回復 2# GBKEE

謝謝GBKEE 版大

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

   顯示"型態不符合"錯誤

TOP

luke

中學生 Rank: 2

帖子: 140
主題: 37
精華: 0
積分: 193
點名: 0
作業系統: Windows XP
軟體版本: Office 2007
閱讀權限: 20
註冊時間: 2012-3-28
最後登錄: 2015-7-5

2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章

5^#

發表於 2012-4-21 11:57 | 只看該作者

回復 3# Hsieh

謝謝H大

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

煩請先進大大指導

TEST13A.rar (24.48 KB)

TOP

Hsieh

超級版主 Rank: 8 Rank: 8

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

2024年全勤獎章 2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

6^#

發表於 2012-4-21 12:41 | 只看該作者

回復 5# luke

無解，sheet2並不分區域，除非在sheet2增加區域欄位

學海無涯_不恥下問

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

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

7^#

發表於 2012-4-21 14:40 | 只看該作者

回復 4# luke
執行5# 的檔案並沒有錯誤發生

TOP

luke

中學生 Rank: 2

帖子: 140
主題: 37
精華: 0
積分: 193
點名: 0
作業系統: Windows XP
軟體版本: Office 2007
閱讀權限: 20
註冊時間: 2012-3-28
最後登錄: 2015-7-5

2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章

8^#

發表於 2012-4-21 15:01 | 只看該作者

回復 6# Hsieh

謝謝H大

如sheet1表E欄給了判斷, 再將勾選後的結果
整理至sheet1表G:I欄如修正數量所示

   請問如何與sheet2表相對應的料號做加總

   煩請先進大大指導

TEST13B.rar (24.53 KB)

TOP

luke

中學生 Rank: 2

帖子: 140
主題: 37
精華: 0
積分: 193
點名: 0
作業系統: Windows XP
軟體版本: Office 2007
閱讀權限: 20
註冊時間: 2012-3-28
最後登錄: 2015-7-5

2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章

9^#

發表於 2012-4-21 15:22 | 只看該作者

回復 7# GBKEE

謝謝GBKEE 回覆

F8逐步執行後顯示"型態不符合"錯誤

TOP

Hsieh

超級版主 Rank: 8 Rank: 8

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

2024年全勤獎章 2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

10^#

發表於 2012-4-21 15:33 | 只看該作者

回復 8# luke

Sub ex()
Dim sp As Shape, A As Range
Set d = CreateObject("Scripting.Dictionary")
With sheet1
For Each sp In .Shapes
If sp.Name Like "Check*" Then
If sp.OLEFormat.Object.Value = 1 Then d(sp.OLEFormat.Object.Caption) = 0
End If
Next
For Each A In .Range(.[A10], .[A10].End(xlDown))
If d.exists(A.Value) = True Then d(A.Offset(, 1) & A.Offset(, 2)) = d(A.Offset(, 1) & A.Offset(, 2)) + A.Offset(, 3)
Next
End With
With sheet2
For Each A In .Range(.[A2], .[A2].End(xlDown))
A.Offset(, 4) = A.Offset(, 2) + d(A & A.Offset(, 1))
Next
End With
End Sub

複製代碼

學海無涯_不恥下問

TOP