[[20091111134022]]　『ﾁｪｯｸﾎﾞｯｸｽの設定方法』（代理人）　ページの最後に飛ぶ

『ﾁｪｯｸﾎﾞｯｸｽの設定方法』（代理人）

ﾁｪｯｸﾎﾞｯｸｽをセル毎に貼付けるやり方で作業実施チェック表を作りたいのですが、①ﾁｪｯｸﾎﾞｯｸｽの□部をセルの中央に配置したい　のと、②□部を大きくしたい　のですが、どうすれば出来ますか？教えて下さい。

 チェック有無で何かしら処理する様でもないので
 セル自体をチェックボックスっぽくしてみては？

 例。

 A1セルを正方形に調整。

 A1セルに罫線で□とする。

 セルの書式設定 → 表示形式 → ユーザー設定で P;P;P;P

 フォントを「Wingdings 2」に設定。

 これでA1セルに何か入力したらレ点が付くよ。

 (gobgob)

gobgob様

ご返答ありがとうございました。
できました。EXCELは奥深い！

早速依頼者に説明したところ、彼曰く
”これだと２クリック必要（・セル選択　・何か入力）。
　１クリックでマーキングできるのが望ましい。
　なのでチェックボックスを使ってみたんだけど・・・"
”大したロスじゃない！”と私は思うのですが、彼には
大問題のようなのです。

ただ、ご返答を見て思うには、そう簡単な事ではないことが
伺い知れました。
ありがとうございました。

 1：A1セルのサイズを大きめに取る。
 2：「コントロールツールボックス」の「チェック ボックス」をA1セル内に置く。
 3：右クリック、「オブジェクトの書式設定」→「プロパティ」で
    「セルにあわせて移動やサイズ変更する」にチェック。
 4：右クリック、「プロパティ」で「Caption」を空白にする。
 5：セルのサイズを変更する。
 6：セルの中央にチェックボックスがくるように調整する。
 7：コントロールツールボックスメニューから「デザインモードの終了」をクリックする。

 ・・・見栄え悪いけど。はい。

 (gobgob)

 　
[[20080908154905]]『チェックボックス』（スガベルト）

 ＶＢＡでの自作チェックボックスです。

 試してみてください。

 ichinose

 おせっかいで、リンク修正↑
（とおりすがり）

gobgob様

別回答ありがとうございました。
出来ました。が、別問題が。

１行にチェックボックス３１個（１～３１日）×１００行超となり、
ファイルOPENや保存に１分以上かかることに。
これではロスが大き過ぎて使えない・・とのことで、チェックボックス
は不採用としました。
いろいろありがとうございました。

ichinose様、とおりすがり様

ご紹介ありがとうございました。
当方EXCEL2000のためか、途中で"このプロパティは･･･"使えないっぽい
エラーメッセージが出て止まってしまいました。
ただ上記のごとくチェックボックス使用を断念しましたので、これ以上の
トライは諦めました。
またの機会にご教示願います。

(代理人)

 >当方EXCEL2000のためか、途中で"このプロパティは･･･"使えないっぽいエラーメッセージ
 手元に2000がないので、参考のためどこでしょうか？
 教えてください。
 BJ

エラーの詳細を記しますと、問合せてくる必要パラメータは全て入力した後、
"Set shp = ActiveSheet.Shapes(Application.Caller).ParentGroup"
部で止まり、メッセージは
"実行時エラー '438'

 ｵﾌﾞｼﾞｪｸﾄはこのﾌﾟﾛﾊﾟﾃｨorﾒｿｯﾄﾞをｻﾎﾟｰﾄしていません"　と出ます。

(管理人)

 ありがとうございました。
 BJ

 ＞１クリックでマーキングできるのが望ましい。
 ダブルクリックと言うのはどうでしょう？

 チェックをつける範囲が分からないので
 A1:A10 と C1:C10 の範囲を想定します。
 この範囲のフォントを「Wingdings 2」に設定しておいて下さい。

 シートモジュールに以下を貼り付け
 '------
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Not Application.Intersect(Target, Range("A1:A10,C1:C10")) Is Nothing Then
        Cancel = True
        Target.Value = IIf(Target.Value = "", "P", "")
    End If
End Sub
 '------

 セルをダブルクリックしてみて下さい。

 (HANA)

 よく考えると、そのセルはチェックにしか使わないと思うので
 右クリックでも良いかもですね。

 これなら、ワンクリックですみます。

 '------
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    If Not Application.Intersect(Target, Range("A1:A10,C1:C10")) Is Nothing Then
        Cancel = True
        Target.Value = IIf(Target.Value = "", "P", "")
    End If
End Sub
 '------

 ついでに
 =COUNTA(A1:A10)
 等で、チェックの数が数えられますね。

 (HANA)

HANA様

 ご回答ありがとうございました。
できました、”１クリックで”！　　これで念願成就です。
また教えて下さい。

しかしフォント「Wingdings 2」は使えますね。

 済みません、右クリックのコードには
 エラー処理を入れるのを忘れていました。
 まだ見て居られましたら、↓に変更して下さい。

 '------
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    If Selection.Count > 1 Then Exit Sub
    If Not Application.Intersect(Target, Range("A1:A10,C1:C10")) Is Nothing Then
        Cancel = True
        Target.Value = IIf(Target.Value = "", "P", "")
    End If
End Sub
 '------

 (HANA)

 もうあまり意味がないかもしれませんが・・・。Excel2000用に改良。

 以下のプロシジャーだけ差し替えて、試してみてください。
 Excel2002でも使えます。

 '===================================================================================
 Sub mycheck_Click()
    Dim ref As String
    Dim gnm As String
    Dim shp As Object
    Dim shpg As Object
    Dim ss As Shape
    Dim nm() As Variant
    Dim g0 As Long
    On Error Resume Next
    If TypeName(Application.Caller) = "String" Then
      Set shp = ActiveSheet.Shapes(Application.Caller)
      Set shpg = shp.GroupItems
      If Err.Number <> 0 Then
         Set shp = shp.ParentGroup
         Set shpg = shp.GroupItems
      End If
      ref = "L" & Replace(shp.Name, " ", "")
      For Each ss In shpg
          ReDim Preserve nm(g0)
          nm(g0) = ss.Name
          g0 = g0 + 1
      Next
      gnm = shp.Name
      shp.Ungroup
      With ActiveSheet
          For g0 = LBound(nm()) To UBound(nm())
            With .Shapes(nm(g0))
                If .Type = 1 Then
                  With .TextFrame.Characters
                      If .Text = "" Then
                        .Text = ChrW(10003)
                        Application.Range(ref).Value = True
                      Else

                        .Text = ""
                        Application.Range(ref).Value = False
                      End If
                  End With
                  Exit For
                End If
            End With
         Next
      End With
      With ActiveSheet.Shapes.Range(nm()).Regroup
          .Name = gnm
          .OnAction = "mycheck_Click"
      End With
   End If
   On Error GoTo 0
 End Sub

 ichinose

コメント返信：

[ 一覧(最新更新順) ]

[[20091111134022]] 『ﾁｪｯｸﾎﾞｯｸｽの設定方法』（代理人） ページの最後に飛ぶ

[[20091111134022]]　『ﾁｪｯｸﾎﾞｯｸｽの設定方法』（代理人）　ページの最後に飛ぶ