麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 核取方塊回存資料 PART~2 [打印本頁]

作者: kai6929 時間: 2012-11-2 11:38 標題: 以巨集的■TRUE,決定資料多寡

請教各位大師們,午安

能否以巨集的功能達到此效果,
1.首先在Sheet1 底下輸入資料後按下■加工一 B3:TRUE 、■加工一 B5:TRUE
2.SHEET2 呈現結果如下

[attach]13013[/attach]

[attach]13014[/attach]

作者: GBKEE 時間: 2012-11-2 16:55

回復 1# kai6929
附檔有三個一般模組都有 check() 這程式會搞糊塗的

複製代碼

作者: kai6929 時間: 2012-11-2 18:16

感謝大師您的回覆,這正是我要的

作者: kai6929 時間: 2012-11-6 14:34 標題: 核取方塊回存資料 PART~2

大師好
         此巨集為某大師幫忙完成之傑作,想在改成達到以下的功能是否可幫幫忙,
1.首先在Sheet1 底下輸入資料後按下
■加工一  C25:= 1 ■加工一  C26:= 1 ■加工一  C27:= 1
2.SHEET2 呈現結果如下項次 L 13以下自動產生
3.在Sheet1 底按下
□加工一  C25:= 0 □加工一  C26:= 0 □加工一  C27:= 0
4.SHEET2 呈現結果如下項次 L13:S27以下清除內容

[attach]13046[/attach]
Option Explicit
Sub check()
Dim K As String, M As Boolean, xRow As Integer, xi As Integer
With ActiveSheet.Shapes(Application.Caller)
      With .TextFrame
         K = .Characters.Text
         If Left(K, 1) = "■" Then
            .Characters.Text = "□加工一"
            M = False
         Else
            .Characters.Text = "■加工一"
            M = True
         End If
         .Characters(1, Len(K) + 1).Font.Size = 10
         .Characters(1, 1).Font.Size = 10
      End With
      .TopLeftCell.Offset(, 1) = M
      .TopLeftCell.Offset(, 2) = IIf(CSng(M) = 0, 0, 1)
End With
Sheet2.UsedRange("L13:S27").ClearContents
xRow = 25
With ActiveSheet
Do While .Cells(xRow, "C") <> ""
      If .Cells(xRow, "C") = 1 Then
         xi = xi + 1
         Sheet2.Rows(1).Copy Sheet2.Cells(Rows.Count, "A").End(xlUp).Offset(1)
         With Sheet2.Cells(Rows.Count, "A").End(xlUp)
         .Cells(1) = xi
         .Cells(12, 14) = ActiveSheet.Cells(xRow, "F")
         .Cells(12, 17) = ActiveSheet.Cells(xRow, "H")
         .Cells(12, 18) = ActiveSheet.Cells(xRow, "J")
         .Cells(12, 19) = ActiveSheet.Cells(xRow, "K")
         End With
      End If
      xRow = xRow + 1
Loop
End With
End Sub
[attach]13047[/attach]

作者: mark15jill 時間: 2012-11-6 15:30

若相同題目.. 建議以原帖回復發問

作者: GBKEE 時間: 2012-11-6 16:48

本帖最後由 GBKEE 於 2012-11-6 16:51 編輯

回復 5# mark15jill
確實是須如此的,一來可知問題的源故 ,二是可節省論壇資源.

回復 4# kai6929
這只是將目原本. 1#發問要複製在Sheet2.A2的資料,移動到Sheet2.L13
試試看

Option Explicit
Sub check()
Dim K As String, M As Boolean, xRow As Integer, xi As Integer
Dim Rng As Range
With ActiveSheet.Shapes(Application.Caller)
With .TextFrame
K = .Characters.Text
If Left(K, 1) = "■" Then
.Characters.Text = "□加工一"
M = False
Else
.Characters.Text = "■加工一"
M = True
End If
.Characters(1, Len(K) + 1).Font.Size = 10
.Characters(1, 1).Font.Size = 10
End With
.TopLeftCell.Offset(, 1) = M
.TopLeftCell.Offset(, 2) = IIf(CSng(M) = 0, 0, 1)
End With
Sheet2.Range("L13").CurrentRegion.Offset(1).Clear
Set Rng = Sheet2.Range("L13").CurrentRegion.Rows(1)
With ActiveSheet
xRow = 25
Do While .Cells(xRow, "C") <> ""
If .Cells(xRow, "C") = 1 Then
xi = xi + 1
Rng.Copy
With Sheet2.Cells(Rows.Count, "L").End(xlUp).Offset(1)
.PasteSpecial
.Cells(1) = xi '項次
'資料存放在合併儲存個的第1個Cells
.Cells(1, 2) = ActiveSheet.Cells(xRow, "A") '加工項目
.Cells(1, 3) = ActiveSheet.Cells(xRow, "F") '加工規格
.Cells(1, 6) = ActiveSheet.Cells(xRow, "H") '(單價)
.Cells(1, 7) = ActiveSheet.Cells(xRow, "I") '次數
.Cells(1, 8) = ActiveSheet.Cells(xRow, "K") '加工費用
End With
End If
xRow = xRow + 1
Loop
End With
Application.CutCopyMode = False
End Sub

複製代碼

作者: mark15jill 時間: 2012-11-6 16:54

回復 6# GBKEE

其實是因為我之前犯過..
被糾正哈哈

作者: kai6929 時間: 2012-11-6 17:27

本帖最後由 kai6929 於 2012-11-6 17:28 編輯

大師真的是厲害的很.
二三下就解決我的問題,但有一事我不明白為何此巨集放到我的 Sheet1 便不能使用.
可以指導一下嗎

作者: kai6929 時間: 2012-11-6 17:32

[attach]13050[/attach]
放在我原有的 Sheet1 便不能使用為什麼?

作者: GBKEE 時間: 2012-11-6 18:01

回復 8# kai6929
那程式碼是給Sheet2用的,資料又要改放Sheet1,有關Sheet2的程式碼,那你要改一下

作者: kai6929 時間: 2012-11-6 18:11

回復 10# GBKEE
請大師指導一下感謝

作者: GBKEE 時間: 2012-11-7 16:54

回復 11# kai6929
上傳修改的檔案看看

作者: kai6929 時間: 2012-11-7 17:30

回復 12# GBKEE

大師可以給我您的 E-mail 我寄給您過目

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