Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10 Home : Excel 2016)
activeXのチェックボックス
投稿日時: 20/12/01 08:04:43
投稿者: ip8bk

いつもお世話になっております。
表題について教えていただきたいのですが、現在A1に表題チェックボックスが一つ埋め込まれていますが、ユーザーフォームのコマンドをクリックして、一つだけA2にコピーすることは可能でしょうか?
 
それぞれlinkedcellを隣のB1, B2に指定して、チェックの有無をセルに表示させたいです。
すみませんが、ご教示お願いいたします。

回答
投稿日時: 20/12/01 10:05:40
投稿者: WinArrow
投稿者のウェブサイトに移動

ユーザーオームをvbModeless
で開いていることと推測します。
 
↓のようなコードでは?
 
Private Sub CommandButton1_Click()
Dim shape As Object
    With ActiveSheet
        .Shapes(1).Duplicate
        Set shape = .Shapes(2)
        shape.Top = .Range("A2").Top
        shape.Left = .Range("A2").Left
        shape.OLEFormat.Object.LinkedCell = "B2"
    End With
         
End Sub

回答
投稿日時: 20/12/01 10:14:47
投稿者: sk

引用:
現在A1に表題チェックボックスが一つ埋め込まれていますが、
ユーザーフォームのコマンドをクリックして、
一つだけA2にコピーすることは可能でしょうか?

「 A2 セルの辺りに新規チェックボックスを挿入したい」のではなく、
あくまで「 A1 セルの辺りにあるチェックボックスをコピーして
A2 セルの辺りに貼り付けたい」ということなのでしょうか。
 
また「ワークシート上にチェックボックスが既に 1 つだけ配置されている状況で
ユーザーフォーム上のコマンドボタンが 1 度だけクリックされた場合」を
例に挙げられていますが、そのコマンドボタンが繰り返し
クリックされた場合はどのようになさりたいのでしょうか。
 
恐らく「 B2 セルとリンクしているチェックボックス」を複数個
A2 セルの辺りに重ねて配置したいわけではないですよね。

投稿日時: 20/12/01 10:29:46
投稿者: ip8bk

コメントありがとうございます。
取り急ぎご回答いたします。
 
 

引用:
「 A2 セルの辺りに新規チェックボックスを挿入したい」のではなく、
あくまで「 A1 セルの辺りにあるチェックボックスをコピーして
A2 セルの辺りに貼り付けたい」ということなのでしょうか。

 
そうです。
 
  
引用:
また「ワークシート上にチェックボックスが既に 1 つだけ配置されている状況で
 ユーザーフォーム上のコマンドボタンが 1 度だけクリックされた場合」を
例に挙げられていますが、そのコマンドボタンが繰り返し
 クリックされた場合はどのようになさりたいのでしょうか。

 
A3、A4..と増やしていきたいです。
 
  
引用:
恐らく「 B2 セルとリンクしているチェックボックス」を複数個、
A2 セルの辺りに重ねて配置したいわけではないですよね。

 
縦に増やしていくことを予定しています。

回答
投稿日時: 20/12/01 11:28:28
投稿者: Suzu

ip8bk さんの引用:
A3、A4..と増やしていきたいです。
 
縦に増やしていくことを予定しています。

 
参考コードをどうぞ。
 
Sub Sample()
  Dim obj As Object
 
  For Each obj In ActiveSheet.OLEObjects
    If InStr(1, obj.progID, "CheckBox", vbBinaryCompare) > 0 Then
      If obj.TopLeftCell.Address = "$A$1" Then
        obj.Copy
        Range("A2").Select
 
        ActiveSheet.Paste
 
        With Selection
          .Top = obj.Top + Range("A1").Height
          .Left = obj.Left
          .LinkedCell = "B2"
          .Object.Value = False
        End With
      End If
    End If
  Next
End Sub
 
位置は、TopLeftCell にて取得できますから、それで判定を行えば良いです。
 
ただ、複数のチェックボックスの左上が、同一セルに 掛かってる事があると、
どれをコピーして良いのか、条件が必要そうですね。

投稿日時: 20/12/01 11:32:07
投稿者: ip8bk

ありがとうございます。
 

ユーザーフォームをvbModeless 
で開いていることと推測します。 
 
↓のようなコードでは? 
 
Private Sub CommandButton1_Click() 
 Dim shape As Object 
     With ActiveSheet 
         .Shapes(1).Duplicate 
         Set shape = .Shapes(2) 
         shape.Top = .Range("A2").Top 
         shape.Left = .Range("A2").Left 
         shape.OLEFormat.Object.LinkedCell = "B2" 
     End With 
          
 End Sub 

 
チェックボックスが複製されますが、下記がでます。
 
オブジェクトはこのプロパティまたはメソッドをサポートしていません。
場所もA2に埋め込まれていなくて、A1とA2の間に作成されてしまいます。

投稿日時: 20/12/01 11:39:25
投稿者: ip8bk

ありがとうございます。
 

引用:
参考コードをどうぞ。
  
Sub Sample()
   Dim obj As Object
   
   For Each obj In ActiveSheet.OLEObjects
     If InStr(1, obj.progID, "CheckBox", vbBinaryCompare) > 0 Then
       If obj.TopLeftCell.Address = "$A$1" Then
         obj.Copy
         Range("A2").Select
   
         ActiveSheet.Paste
   
         With Selection
           .Top = obj.Top + Range("A1").Height
           .Left = obj.Left
           .LinkedCell = "B2"
           .Object.Value = False
         End With
       End If
     End If
   Next
 End Sub
   
位置は、TopLeftCell にて取得できますから、それで判定を行えば良いです。
  
ただ、複数のチェックボックスの左上が、同一セルに 掛かってる事があると、
どれをコピーして良いのか、条件が必要そうですね。

 
複製されましたが、下記のエラーが出てしまいます。
なにか私のエクセルの設定が邪魔しているのでしょうか?
 
実行時エラー1004
RangeクラスのTopプロパティを設定できません。
 

回答
投稿日時: 20/12/01 13:50:42
投稿者: Suzu

引用:

複製されましたが、下記のエラーが出てしまいます。
なにか私のエクセルの設定が邪魔しているのでしょうか?
 
実行時エラー1004
RangeクラスのTopプロパティを設定できません。

 
当方のテストでは再現できません。コード改変していませんか?
 
Rangeの、Top との事ですので
 
        With Selection
MsgBox "A"
            MsgBox TypeName(Selection)
            MsgBox .Top
            MsgBox obj.Top
            MsgBox Range("A1").Height
      .Top = obj.Top + Range("A1").Height  ←ここでエラーになっていると考えられる。
 
提示した赤の様に MsgBox にて、各値を確認する。等、ご自身で確認する術をお持ちください。
 
MsgBox TypeName(Selection)
の部分で、Selection は、
当方のコードであれば、OLEObject になっていないといけません。
それが、Range になっているのではありませんか?
 
 
エラー状況を伝えてどうしたいのでしょう。
 
一から十まで希望の動作をするコードが欲しいと言うのであれば
当方はここまでとさせて頂きます。

回答
投稿日時: 20/12/01 14:05:23
投稿者: WinArrow
投稿者のウェブサイトに移動

ip8bk さんの引用:

チェックボックスが複製されますが、下記がでます。
 
オブジェクトはこのプロパティまたはメソッドをサポートしていません。
場所もA2に埋め込まれていなくて、A1とA2の間に作成されてしまいます。

こちらではテストして掲示しています。
 
設置したチェックボックスが、本当にActiveXのものですか??
 
 

投稿日時: 20/12/01 14:29:29
投稿者: ip8bk

withをコメントアウトにすると、問題なくチェックボックスが1つA2セルに複製されます。(事前に行幅をそろえておく必要がありますが)
 
withのなかのコードは1つずつ確認しましたが、どれもエラーになってしまいます。
 
 

Sub Sample()
    Dim obj As Object
    
    For Each obj In ActiveSheet.OLEObjects
      If InStr(1, obj.progID, "CheckBox", vbBinaryCompare) > 0 Then
        If obj.TopLeftCell.Address = "$A$1" Then
          obj.Copy
          Range("A2").Select
    
          ActiveSheet.Paste
    
'          With Selection
'            .Top = obj.Top + Range("A1").Height
'            .Left = obj.Left
'            .LinkedCell = "B2"
'            .Object.Value = False
'          End With
        End If
      End If
    Next
End Sub

 
引用:
当方のテストでは再現できません。コード改変していませんか?

 
もちろん修正などは行っておりません。そのまま使用している状態で質問させていただいております。
 
 
引用:
エラー状況を伝えてどうしたいのでしょう。

 
withも必要なので使えるようにしたいです。
 

投稿日時: 20/12/01 14:47:02
投稿者: ip8bk

引用:
こちらではテストして掲示しています。
  
設置したチェックボックスが、本当にActiveXのものですか??

 
お手数をお掛けしております。
間違いなくActiveXの方のチェックボックスを使用しています。
 
 
shape.OLEFormat.Object.LinkedCell = "B2"

 
上記コードで下記のエラーが出ているようです。
コメントアウトするとエラーなく終わりますが、チェックボックスやコマンドが左上のA1とA2に移動されてしまいます。
 
実行時エラー 2147467359(80004005)
LinkedCellメソッドは失敗しました。OLEObjectオブジェクト

回答
投稿日時: 20/12/01 16:00:26
投稿者: sk

引用:
A1 セルの辺りにあるチェックボックスをコピーして
A2 セルの辺りに貼り付けたい

引用:
A3、A4..と増やしていきたいです。

(フォームモジュール)
------------------------------------------------------------
Option Explicit
 
Private Const SheetName As String = "Sheet1"
 
Private wsEdit As Excel.Worksheet
Private oleFirst As Excel.OLEObject
Private oleLast As Excel.OLEObject
 
Private Sub UserForm_Initialize()
     
    CommandButton1.Enabled = False
     
    Set wsEdit = Worksheets(SheetName)
     
    wsEdit.Select
    wsEdit.Cells(1, 1).Select
     
    Call GetCheckBoxes
 
    If oleFirst Is Nothing Then
        MsgBox "[" & wsEdit.Name & "] には、セルとリンクしているチェックボックスがありません。", _
               vbExclamation, _
               "エラー"
        Exit Sub
    End If
 
    CommandButton1.Enabled = True
 
End Sub
 
Private Sub UserForm_Terminate()
 
    Set oleFirst = Nothing
    Set oleLast = Nothing
    Set wsEdit = Nothing
 
End Sub
 
Private Sub CommandButton1_Click()
     
    Call DuplicateCheckBox
     
End Sub
 
Private Sub GetCheckBoxes()
 
    Dim oleobj As Excel.OLEObject
    Dim lngRow As Long
    Dim lngFirstRow As Long
    Dim lngLastRow As Long
 
    lngFirstRow = 0
    lngLastRow = 0
 
    For Each oleobj In wsEdit.OLEObjects
        If oleobj.progID = "Forms.CheckBox.1" And oleobj.LinkedCell <> "" Then
            lngRow = wsEdit.Range(oleobj.LinkedCell).Row
            If lngFirstRow = 0 Or lngFirstRow > lngRow Then
                lngFirstRow = lngRow
                Set oleFirst = oleobj
            End If
            If lngLastRow < lngRow Then
                lngLastRow = lngRow
                Set oleLast = oleobj
            End If
        End If
    Next
 
End Sub
 
Private Sub DuplicateCheckBox()
 
    If oleFirst Is Nothing Then
        Exit Sub
    End If
     
    If oleLast Is Nothing Then
        Exit Sub
    End If
     
    Dim lngNewRow As Long
    Dim sngLeft As Single
    Dim sngTop As Single
    Dim strLinkedCell As String
     
    sngLeft = oleFirst.Left
    sngTop = oleLast.TopLeftCell.Offset(1, 0).Top + (oleFirst.Top - oleFirst.TopLeftCell.Top)
    strLinkedCell = wsEdit.Range(oleLast.LinkedCell).Offset(1, 0).Address
     
    Dim oleNew As Excel.OLEObject
 
    Set oleNew = oleFirst.Duplicate
     
    With oleNew
        Application.ScreenUpdating = False
        .Left = sngLeft
        .Top = sngTop
        .LinkedCell = strLinkedCell
        wsEdit.Range(.LinkedCell).Value = False
        Application.ScreenUpdating = True
        .TopLeftCell.Select
    End With
     
    Set oleLast = oleNew
     
 
End Sub
------------------------------------------------------------
 
以上のような処理を実現したい、ということでしょうか。

投稿日時: 20/12/02 12:59:14
投稿者: ip8bk

この掲示板のレベルの高さに感動しました。
すべて理想通りに動いております。
大変ありがとうございました。
 
一点の質問ていただきたい部分がありますので、質問させていただきます。
 
GetCheckBoxesに下記のコードがありましたが、lngFirstRow=0だけでも動作するのですが、Orの右の部分はどのようなことを想定されているのでしょうか?
 

If lngFirstRow = 0 Or lngFirstRow > lngRow Then

回答
投稿日時: 20/12/02 14:33:30
投稿者: sk

引用:
GetCheckBoxesに下記のコードがありましたが、lngFirstRow=0だけでも動作するのですが、
Orの右の部分はどのようなことを想定されているのでしょうか?

端的に言えば、「最初に作成されたチェックボックス」ではなく
「 B 列の最初の行のセルとリンクしているチェックボックス」を
より確実に参照するためです。
 
引用:
For Each oleobj In wsEdit.OLEObjects

上記の For Each ... In ... ステートメントでは、変数 wsEdit が
参照しているワークシート上に埋め込まれている全ての OLE オブジェクトを
1 つずつ参照しているわけですが、その際に各オブジェクトを参照する順番は
オブジェクトが作成された順」です。
 
------------------------------------------------------------
 
1. 新規ブックを作成する。
 
2. ワークシート[Sheet1]上にチェックボックス(以下[CheckBox1])を
   適当な位置に挿入する。
    
3. 続けてもう 1 つチェックボックス(以下[CheckBox2])を
   適当な位置に挿入する。
 
4. (後から挿入した)[CheckBox2]を A1 セルの内側辺りに移動させ、
   その LinkedCell プロパティに「$B$1」を設定する。
 
5. (最初に挿入した)[CheckBox1]を A2 セルの内側辺りに移動させ、
   その LinkedCell プロパティに「$B$2」を設定する。
 
------------------------------------------------------------
 
例えば上記のような操作が行われていた場合、前述の For Each ... In ...
ステートメントにおいて、1 回目のループで変数 oleobj に渡されるのは、
1 行目にある(後から挿入した)[CheckBox2]ではなく
2 行目にある(最初に挿入した)[CheckBox1]への参照です。
 
引用:
lngRow = wsEdit.Range(oleobj.LinkedCell).Row
If lngFirstRow = 0 Or lngFirstRow > lngRow Then
    lngFirstRow = lngRow
    Set oleFirst = oleobj
End If

この時、lngFirstRow = 0 という条件のみで判定するようにすると、
1 回目のループの時点で変数 oleFirst が参照するオブジェクト
(コマンドボタンのクリック時に複製されるチェックボックス)が
B2 セルとリンクしている[CheckBox1]に確定されることになります。
 
それで特に支障がないのであればそのままでも構いませんが、
あくまでも B1 セルとリンクしている[CheckBox2]を複写元としたい
(リンクしているセルの行位置、もしくはそのチェックボックスが
配置されているセル範囲の左上のセルの行位置を基準としたい)場合、
前述のような「チェックボックスが作成された順」との不整合が
起こる可能性は極力排除しなければならないでしょう。
 
「複合条件で判定するのがどうもしっくりこない」ということであれば、
lngFirstRow の初期値として極端に大きな数値を代入しておくという形を
取られてもよいと思います。

投稿日時: 20/12/18 12:26:42
投稿者: ip8bk

理解いたしました。(そこまで理解してくれていたのですね。大感謝です)
ご回答いただき誠にありがとうございました。
これで解決させていただきます。