以巨集的■TRUE,決定資料多寡

請教各位大師們,午安

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

kai~19.rar (100.73 KB)

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兔年全勤獎章

2^#

發表於 2012-11-2 16:55 | 只看該作者

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

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.Offset(1).Clear
xRow = 3
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(1, 3) = ActiveSheet.Cells(xRow, "D")
.Cells(1, 6) = ActiveSheet.Cells(xRow, "H")
.Cells(1, 7) = ActiveSheet.Cells(xRow, "I")
.Cells(1, 9) = ActiveSheet.Cells(xRow, "K")
End With
End If
xRow = xRow + 1
Loop
End With
End Sub

複製代碼

TOP

kai6929

中學生 Rank: 2

帖子: 84
主題: 24
精華: 0
積分: 118
點名: 0
作業系統: xp
軟體版本: offcie 2007
閱讀權限: 20
註冊時間: 2010-5-6
最後登錄: 2025-7-2

3^#

發表於 2012-11-2 18:16 | 只看該作者

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

TOP

kai6929

中學生 Rank: 2

帖子: 84
主題: 24
精華: 0
積分: 118
點名: 0
作業系統: xp
軟體版本: offcie 2007
閱讀權限: 20
註冊時間: 2010-5-6
最後登錄: 2025-7-2

4^# 倒序看帖

打印

字體大小: tT

發表於 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以下清除內容

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)

1 評分人數