[發問] 核取方塊 回存資料 PART~2

kai6929

請教各位大師們,午安

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

kai~19.rar (100.73 KB)

下載次數: 8

2012-11-2 11:34

下載 (170.67 KB)

2012-11-2 11:34

GBKEE

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

1. Option Explicit
   
2. Sub check()
   
3.     Dim K As String, M As Boolean, xRow As Integer, xi As Integer
   
4.     With ActiveSheet.Shapes(Application.Caller)
   
5.         With .TextFrame
   
6.             K = .Characters.Text
   
7.             If Left(K, 1) = "■" Then
   
8.                 .Characters.Text = "□加工一"
   
9.                 M = False
   
10.             Else
    
11.                 .Characters.Text = "■加工一"
    
12.                 M = True
    
13.             End If
    
14.             .Characters(1, Len(K) + 1).Font.Size = 10
    
15.             .Characters(1, 1).Font.Size = 10
    
16.         End With
    
17.         .TopLeftCell.Offset(, 1) = M
    
18.         .TopLeftCell.Offset(, 2) = IIf(CSng(M) = 0, 0, 1)
    
19.     End With
    
20.     Sheet2.UsedRange.Offset(1).Clear
    
21.     xRow = 3
    
22.     With ActiveSheet
    
23.     Do While .Cells(xRow, "C") <> ""
    
24.         If .Cells(xRow, "C") = 1 Then
    
25.             xi = xi + 1
    
26.             Sheet2.Rows(1).Copy Sheet2.Cells(Rows.Count, "A").End(xlUp).Offset(1)
    
27.            With Sheet2.Cells(Rows.Count, "A").End(xlUp)
    
28.            .Cells(1) = xi
    
29.            .Cells(1, 3) = ActiveSheet.Cells(xRow, "D")
    
30.            .Cells(1, 6) = ActiveSheet.Cells(xRow, "H")
    
31.            .Cells(1, 7) = ActiveSheet.Cells(xRow, "I")
    
32.            .Cells(1, 9) = ActiveSheet.Cells(xRow, "K")
    
33.            End With
    
34.         End If
    
35.         xRow = xRow + 1
    
36.     Loop
    
37.     End With
    
38. End Sub

複製代碼

kai6929

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

kai6929

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

下載 (60.59 KB)

2012-11-6 14:33

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
kai~20.rar (72.82 KB)

下載次數: 6

2012-11-6 14:34

mark15jill

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

GBKEE

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

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

1. Option Explicit
   
2. Sub check()
   
3.     Dim K As String, M As Boolean, xRow As Integer, xi As Integer
   
4.     Dim Rng As Range
   
5.     With ActiveSheet.Shapes(Application.Caller)
   
6.         With .TextFrame
   
7.             K = .Characters.Text
   
8.             If Left(K, 1) = "■" Then
   
9.                 .Characters.Text = "□加工一"
   
10.                 M = False
    
11.             Else
    
12.                 .Characters.Text = "■加工一"
    
13.                 M = True
    
14.             End If
    
15.             .Characters(1, Len(K) + 1).Font.Size = 10
    
16.             .Characters(1, 1).Font.Size = 10
    
17.         End With
    
18.         .TopLeftCell.Offset(, 1) = M
    
19.         .TopLeftCell.Offset(, 2) = IIf(CSng(M) = 0, 0, 1)
    
20.     End With
    
21.     Sheet2.Range("L13").CurrentRegion.Offset(1).Clear
    
22.     Set Rng = Sheet2.Range("L13").CurrentRegion.Rows(1)
    
23.     With ActiveSheet
    
24.         xRow = 25
    
25.         Do While .Cells(xRow, "C") <> ""
    
26.             If .Cells(xRow, "C") = 1 Then
    
27.                 xi = xi + 1
    
28.                 Rng.Copy
    
29.                 With Sheet2.Cells(Rows.Count, "L").End(xlUp).Offset(1)
    
30.                     .PasteSpecial
    
31.                     .Cells(1) = xi                               '項次
    
32.                     '資料存放在合併儲存個的第1個Cells
    
33.                     .Cells(1, 2) = ActiveSheet.Cells(xRow, "A")  '加工項目
    
34.                     .Cells(1, 3) = ActiveSheet.Cells(xRow, "F")  '加工規格
    
35.                     .Cells(1, 6) = ActiveSheet.Cells(xRow, "H")  '(單價)
    
36.                     .Cells(1, 7) = ActiveSheet.Cells(xRow, "I")  '次數
    
37.                     .Cells(1, 8) = ActiveSheet.Cells(xRow, "K")  '加工費用
    
38.                 End With
    
39.             End If
    
40.             xRow = xRow + 1
    
41.         Loop
    
42.     End With
    
43.     Application.CutCopyMode = False
    
44. End Sub

複製代碼

mark15jill

回復 6# GBKEE

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

kai6929

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

kai6929

下載 (52.49 KB)

2012-11-6 17:31

放在我原有的  Sheet1 便不能使用為什麼?

GBKEE

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