[[20120616162440]]　『リストボックスがVBA実行で消える』（しんぽん）　ページの最後に飛ぶ

『リストボックスがVBA実行で消える』（しんぽん）

　ある結合セルに、別のシートから参照入力するためのリストボックスを
データの入力規則＋INDIRECT関数で作成していたのですが、マクロを
実行するとリストボックスを表示させる矢印(セルをクリックすると表示
する矢印)が消えてしまいます。恐らく結合セルを使っているのが悪いと
思われるのですが、帳票のレイアウト上、結合セルを使わざるを得ないので、
何か解決方法は無いでしょうか？宜しくお願い致します。

 >マクロを実行するとリストボックスを表示させる矢印(セルをクリックすると表示 
 >する矢印)が消えてしまいます。

 こういうご質問の場合、まず、問題の現象を再現できる手順書を作成してください。
 その過程でコードの提示が必要ならそれも提示してください。

 ichinose

ichinose様
　いつも大変お世話になっております。説明不足で申し訳ございません。

　起こっている現象ですが、sheet1のV3:AF4のセル範囲で以下の結合セルが
あります。
①V3:W4で結合、平成(文字列)を入力
②X3:Y4で結合、データの入力規則で=INDIRECT("sheet2!B3:B9"))を入力。
　(B3に24、B4に25、B5に26・・・・、B9に30)
③Z3:Z4で結合、年(文字列)を入力
④AA3:AB4で結合、データの入力規則で=INDIRECT("sheet2!C3:C14"))を入力。
　(C3に1、C4に2、C5に3・・・・、C14に12)
⑤AC3:AC4で結合、月(文字列)を入力
⑥AD3:AE4で結合、データの入力規則で=INDIRECT("sheet2!D3:D33"))を入力。
　(D3に1、D4に2、D5に3・・・・、D33に31)
⑦AF3:AF4で結合、日(文字列)を入力
これで年月日をリストボックスから数字入力できるようにしていました。

　マクロは先日ichinose様に教えていただいたもので、上記セル範囲の下のエリアの
sheet1のD8,D10,D12,D14,D16,D18,D20の７つのセルに、それぞれコマンドボタンを
配置し、それぞれのボタンを押すとI8:BD8,I10:BD10・・・・,I20:BD20の範囲に
sheet3に作図してあるデータ(文字列＋矢印)が貼り付きます。

　このマクロ実行をすると、なぜかX3,AA3,AD3のこれまであった、セルをクリックすると
現れる矢印が消えてしまい、リストボックスが使えなくなります。

　宜しく御願い致します。

 >マクロは先日ichinose様に教えていただいたもの
 でも、最終的にどのコードなのかは、私には、わかりませんよね！！
 本当は、どのコードの実行なのかは、明確に記述してほしかったのですが・・・。

 前回投稿を眺めて、気になったは、

 >'一日目既存のデータを消去(新データ貼り付け範囲のみ) 
 >Dim myRng As Range 
 >Dim sp As Variant 
 >Set myRng = Range(Cells(8, 最左), Cells(8, 56)) 
 >myRng.Select 
 >Selection.ClearContents 
 >For Each sp In ActiveSheet.Shapes 
   >If Not Intersect(Range(sp.TopLeftCell, sp.BottomRightCell), myRng) Is Nothing Then 
      >sp.Delete 
   >End If 
 >Next sp 
 >Set myRng = Nothing

 このコードも実行マクロの中に含まれているのであれば、記述された現象になる可能性は
 あります。

 何があぶないかというと、

 >For Each sp In ActiveSheet.Shapes 
   >If Not Intersect(Range(sp.TopLeftCell, sp.BottomRightCell), myRng) Is Nothing Then 
      >sp.Delete 
   >End If 
 >Next sp

 Shapesコレクションには、入力規則のリストで使われるコンボボックスも含まれてしまいます。
 削除する条件に合えば、このコンボボックスも削除されてしまうということです。

 For Each sp In ActiveSheet.DrawingObjects

 とすれば、今度は、図形コレクションに入力規則のコンボボックスは、コレクションの対象外になります。
 尚、spという変数の型もShapeから　Objectに変更してください。

 まずこれで試してみてください

 ichinose

ichinose様

　またまた説明不足で誠に申し訳ございませんでした。
以後、気をつけます。コードのほうは完成しましたら
掲載させていただきます。

　今回ご指導いただいた内容を試してみましたところ、
なんとっ、リストボックスが消えなくなりました！
感謝感激です！
(但し一度消してしまったリストボックスは再度作成
しても現れず、シートを作り直しました)

　このたびは色々とお世話になり、本当にありがとう
ございました。何とお礼を申し上げたらよいやら、
これで目的の帳票（運行指示書）が完成できそうです。
　　　　　　　　　　　　↓
　社内(零細企業です・・・)でこの運行指示書(先日の
関越道バス事故発生で作成の徹底が求められている)
の作成には時間がかかるので、作成時間短縮のために
半自動的に作成できるものを作って欲しいとの要望が
あり、今回トライしたという経緯がありました。

ichinose様
　やっとコードが完成しました。ちょっと変数を使い過ぎなのでしょうか？

 ●標準モジュール
 Option Explicit
 Public Sub form1()
 '*日目ボタンの座標(Row)をラベルに取得
    UserForm1.Controls("LblAddress").Caption = ActiveSheet.Shapes(Application.Caller).TopLeftCell.Row
 'フォームのボタンに名前をふる
    Dim i As Long
    Dim k As Long
       With Sheets("便登録")
           For i = 1 To 20
               k = i * 3 + 2
               UserForm1.Controls("CommandButton" & i).Caption = .Range("B" & k).Value
           Next i
       End With  
 'フォームを表示
    UserForm1.Show
 End Sub

 ●ユーザーフォームモジュール
 Option Explicit
 Private Sub Kihondosa_Click_Sub(ByVal Index As Integer)
 'ユーザーフォームを閉じる
    UserForm1.Hide
 '変数の定義
    Dim lbn As Long
    Dim i As Long
    Dim k As Long
    Dim st() As Long
    Dim sk() As Long
    Dim 最左線 As Long
    Dim 最右線 As Long
    Dim 一最左列 As Long
    Dim 二最右列 As Long
    Dim 最左 As Long
    Dim 最右 As Long
    Dim 一最左セル As Range
    Dim 二最右セル As Range
    Dim rng As Range
    Dim rng1 As Range
    Dim rng2 As Range
    Dim myRng As Range
    Dim myRng1 As Range
    Dim myRng2 As Range
    Dim myRng3 As Range
    Dim sp As Object
    Dim sp1 As Object
    Dim sp2 As Object

 'ボタン位置のRowを取得(ラベルNo.のプロパティー)
    lbn = UserForm1.lblAddress.Caption

 '便登録シート登録No.Indexの一日目登録データ取り込み
    Worksheets("便登録").Activate 
    On Error Resume Next
    Set myRng1 = Range(Cells(Index * 3 + 1, 9), Cells(Index * 3 + 1, 56))
    Set rng1 = myRng1.SpecialCells(xlCellTypeConstants)

    i = 0
    For Each sp1 In ActiveSheet.DrawingObjects
      If Not Intersect(Range(sp1.TopLeftCell, sp1.BottomRightCell), myRng1) Is Nothing Then
          i = i + 1
          ReDim Preserve st(1 To i)
          st(i) = sp1.TopLeftCell.Column
      End If
    Next sp1

    If i <> 0 And Not rng1 Is Nothing Then
        Set 一最左セル = rng1.Cells(1)
        一最左列 = 一最左セル.Column
        最左線 = Application.WorksheetFunction.Min(st())
        最左 = Application.WorksheetFunction.Min(一最左列, 最左線)
     ElseIf i = 0 And Not rng1 Is Nothing Then
        Set 一最左セル = rng1.Cells(1)
        一最左列 = 一最左セル.Column
        最左 = 一最左列
     ElseIf i <> 0 And rng1 Is Nothing Then
        最左線 = Application.WorksheetFunction.Min(st())
        最左 = 最左線
     Else
        MsgBox "1日目の登録データがありません"
        GoTo Label1
     End If

    '指示書シートに移動
      Worksheets("指示書").Activate
    '一日目既存のデータを消去(新データ貼り付け範囲のみ)
      Set myRng = Range(Cells(lbn, 最左), Cells(lbn, 56))
          myRng.Select
      Selection.ClearContents
      For Each sp In ActiveSheet.DrawingObjects
          If Not Intersect(Range(sp.TopLeftCell, sp.BottomRightCell), myRng) Is Nothing Then
              sp.Delete
          End If
      Next sp
      Set myRng = Nothing
      Set sp = Nothing

    '一日目の登録データをコピー
      Sheets("便登録").Select
      Range(Cells(Index * 3 + 1, 最左), Cells(Index * 3 + 1, 56)).Copy
      Sheets("指示書").Select
      Cells(lbn, 最左).Select
      ActiveSheet.Paste

 Label1:

 '７日目ボタンの 二日目登録データ取込みスキップ
    If lbn = 20 Then
        GoTo Label2
    End If

 '便登録シート登録No.Indexの二日目登録データ取り込み
     Worksheets("便登録").Activate  
     Set myRng2 = Range(Cells(Index * 3 + 2, 9), Cells(Index * 3 + 2, 56))
     Set rng2 = myRng2.SpecialCells(xlCellTypeConstants)
     Set rng = rng2.Areas(rng2.Areas.Count)

     k = 0
     For Each sp2 In ActiveSheet.DrawingObjects
         If Not Intersect(Range(sp2.TopLeftCell, sp2.BottomRightCell), myRng2) Is Nothing Then
            k = k + 1
            ReDim Preserve sk(1 To k)
            sk(k) = sp2.BottomRightCell.Column
         End If
     Next sp2

    If k <> 0 And Not rng2 Is Nothing Then
         Set 二最右セル = rng.Cells(rng.Count)
         二最右列 = 二最右セル.Column
         最右線 = Application.WorksheetFunction.Max(sk())
         最右 = Application.WorksheetFunction.Max(二最右列, 最右線)
    ElseIf k = 0 And Not rng2 Is Nothing Then
         Set 二最右セル = rng.Cells(rng.Count)
         二最右列 = 二最右セル.Column
         最右 = 二最右列
    ElseIf k <> 0 And rng2 Is Nothing Then
         最右線 = Application.WorksheetFunction.Max(sk())
         最右 = 最右線
    Else
         MsgBox "2日目の登録データがありません"
         GoTo Label2
    End If

    '指示書シートに移動
     Worksheets("指示書").Activate
    '二日目既存のデータを消去(新データ貼り付け範囲のみ)
      Set myRng = Range(Cells(lbn + 2, 9), Cells(lbn + 2, 最右))
          myRng.Select
      Selection.ClearContents
        For Each sp In ActiveSheet.DrawingObjects
          If Not Intersect(Range(sp.TopLeftCell, sp.BottomRightCell), myRng) Is Nothing Then
            sp.Delete
          End If
        Next sp
      Set myRng = Nothing
      Set sp = Nothing

    '二日目の登録データをコピー
      Sheets("便登録").Select
      Range(Cells(Index * 3 + 2, 9), Cells(Index * 3 + 2, 最右)).Copy
      Sheets("指示書").Select
      Cells(lbn + 2, 9).Select
      ActiveSheet.Paste    
 Label2:
    Worksheets("指示書").Activate

 End Sub

 Private Sub CommandButton1_Click()
    Call Kihondosa_Click_Sub(1)
End Sub
Private Sub CommandButton2_Click()
    Call Kihondosa_Click_Sub(2)
End Sub
Private Sub CommandButton3_Click()
    Call Kihondosa_Click_Sub(3)
End Sub
Private Sub CommandButton4_Click()
    Call Kihondosa_Click_Sub(4)
End Sub
Private Sub CommandButton5_Click()
    Call Kihondosa_Click_Sub(5)
End Sub
Private Sub CommandButton6_Click()
    Call Kihondosa_Click_Sub(6)
End Sub
Private Sub CommandButton7_Click()
    Call Kihondosa_Click_Sub(7)
End Sub
Private Sub CommandButton8_Click()
    Call Kihondosa_Click_Sub(8)
End Sub
Private Sub CommandButton9_Click()
    Call Kihondosa_Click_Sub(9)
End Sub
Private Sub CommandButton10_Click()
    Call Kihondosa_Click_Sub(10)
End Sub
Private Sub CommandButton11_Click()
    Call Kihondosa_Click_Sub(11)
End Sub
Private Sub CommandButton12_Click()
    Call Kihondosa_Click_Sub(12)
End Sub
Private Sub CommandButton13_Click()
    Call Kihondosa_Click_Sub(13)
End Sub
Private Sub CommandButton14_Click()
   Call Kihondosa_Click_Sub(14)
End Sub
Private Sub CommandButton15_Click()
   Call Kihondosa_Click_Sub(15)
End Sub
Private Sub CommandButton16_Click()
   Call Kihondosa_Click_Sub(16)
End Sub
Private Sub CommandButton17_Click()
   Call Kihondosa_Click_Sub(17)
End Sub
Private Sub CommandButton18_Click()
   Call Kihondosa_Click_Sub(18)
End Sub
Private Sub CommandButton19_Click()
   Call Kihondosa_Click_Sub(19)
End Sub
Private Sub CommandButton20_Click()
   Call Kihondosa_Click_Sub(20)
End Sub
Private Sub CommandButton21_Click()
    'フォームを閉じる
    Unload UserForm1
End Sub

 ●Sheet1モジュール(入力データをリセットするコマンド)
 Option Explicit
 Private Sub CommandButton1_Click()
 'リセット下ボタン
 'オートシェイプ(矢印等)の削除
    Dim lngLeft   As Long
    Dim lngTop    As Long
    Dim lngRight As Long
    Dim lngBottom As Long
    Dim objShape As Object

    With Range("I8:BD21")
        lngTop = .Top
        lngLeft = .Left
        lngBottom = .Top + .Height
        lngRight = .Left + .Width
    End With

    For Each objShape In ActiveSheet.DrawingObjects
        With objShape
            If lngTop <= .Top And lngLeft <= .Left And _
                lngBottom >= .Top + .Height And lngRight >= .Left + .Width Then
                .Delete
            End If
        End With
    Next
 '文字列の削除
    ActiveSheet.Range("I8", "BD21").Select
    Selection.ClearContents 
 End Sub

 Private Sub CommandButton2_Click()
 'リセット上ボタン(文字列削除)
    ActiveSheet.Range("X3,AA3,AD3,AK3,AN3,V5,AE5,AO5,AV4,AY4,BB4").Select
    Selection.ClearContents
 End Sub

[[20120531104000]]

 ここでの内容が大きく関わっているということでリンク貼っときます。

 今回のご質問の
 >リストボックスを表示させる矢印(セルをクリックすると表示 
 >する矢印)が消えてしまいます
 結構有名な現象なので、この時点で見当はついていましたが、敢えて再現手順書を
 記述してください　と申し上げました。誰でもが再現できる手順書を記述すること、
 繰り返しますが、大事ですよ！！

 入力規則のリストのコンボボックスとShape及び、Shapesコレクションについて

 入力規則のリストのコンボボックスは、Shapesコレクションに含まれているので、
 削除してしまうと、このシートを再度作り直すしかなさそうですね！！
 同じような事象にオートフィルタのコンボボックスも該当しますから、注意です。
 もっとも2002では、オートフィルタのそれは、再生できます。

 コードは、ざっとですが、拝見しました。
 仕様などは見ていませんが・・・。
 ユーザーフォームも使っているのですね！！

 > Private Sub CommandButton1_Click()
 >   Call Kihondosa_Click_Sub(1)
 >End Sub
 >Private Sub CommandButton2_Click()
 >   Call Kihondosa_Click_Sub(2)
 >End Sub

 この様な記述が沢山ありますねえ！！
 このような場合､クラスモジュールを使って
 配列コントロールを実現する方法もあります。
 まっ、ご自分の判断でこの程度だったら、クラスモジュールを使うほどでもない
 という結論もあるでしょうから、これはこれでよいでしょうが・・・・。

 気になったのは、Kihondosa_Click_Sub内の二つのラベルとGoto文です。

 なくてもコードは書けますし、それの方がわかりやすいと思います。
 Gotoを使わないで、コードを書き直すことを検討してみてください。

 もう一つが同じKihondosa_Click_Sub内の

 UserForm1.Hide

 このメソッドでユーザーフォームを非表示にしていますが、
 その後、再びShow　している箇所もUnloadもしていません。
 これ、見えないので動作的に同じように見えますが、
 Hideは、ユーザーフォームをあくまでも非表示でユーザーフォームというオブジェクトは
 残ったままです。処理が完結しているなら、Unload Me　を入れた方が良いですよ！！

 以上です、気になった点を記述しました。

 ichinose

ichinose様

　最後までご指導いただき、誠にありがとうございました。

　クラスモジュールについてはまだよく理解できていません
ので勉強中です(擬似への脱却を読んでいますが・・・)。

　Goto Labelを使わず書き直す方法？？？？
なにとぞ、ヒントをいただけないでしょうか？

　UserForm1.Hideは、単に非表示にしていただけなのですね・・・
Unloadに直します。

 >Goto Labelを使わず書き直す方法？？？？
 構造化プログラミングの学習をされたらいかがでしょうか？
 そうすれば、階層構造を作る　ということを学びます。

 これは、一例です

 Private Sub Kihondosa_Click_Sub(ByVal Index As Integer)
 '変数の定義
    Dim lbn As Long
    Dim 最左 As Long
    Dim 最右 As Long
    Dim myRng As Range
    Dim myRng1 As Range
    Dim sp As Object

 'ボタン位置のRowを取得(ラベルNo.のプロパティー)
    lbn = UserForm1.LblAddress.Caption

 '便登録シート登録No.Indexの一日目登録データ取り込み
    Worksheets("便登録").Activate
    On Error Resume Next
    Set myRng1 = Range(Cells(Index * 3 + 1, 9), Cells(Index * 3 + 1, 56))
    最左 = get_Obj最左右列(myRng1, 1)
    If 最左 = 0 Then
        MsgBox "1日目の登録データがありません"
    Else
       '指示書シートに移動
       Worksheets("指示書").Activate
       '一日目既存のデータを消去(新データ貼り付け範囲のみ)
       Set myRng = Range(Cells(lbn, 最左), Cells(lbn, 56))
       myRng.Select
       Selection.ClearContents
       For Each sp In ActiveSheet.DrawingObjects
          If Not Intersect(Range(sp.TopLeftCell, sp.BottomRightCell), myRng) Is Nothing Then
              sp.Delete
          End If
       Next sp
       Set myRng = Nothing
       Set sp = Nothing
       '一日目の登録データをコピー
       Sheets("便登録").Select
       Range(Cells(Index * 3 + 1, 最左), Cells(Index * 3 + 1, 56)).Copy
       Sheets("指示書").Select
       Cells(lbn, 最左).Select
       ActiveSheet.Paste
    End If

 '便登録シート登録No.Indexの二日目登録データ取り込み
     Worksheets("便登録").Activate
     Set myRng1 = Range(Cells(Index * 3 + 2, 9), Cells(Index * 3 + 2, 56))
     最右 = get_Obj最左右列(myRng1, 2)
    If 最右 = 0 Then
       MsgBox "2日目の登録データがありません"
    Else
       '指示書シートに移動
       Worksheets("指示書").Activate
       '二日目既存のデータを消去(新データ貼り付け範囲のみ)
       Set myRng = Range(Cells(lbn + 2, 9), Cells(lbn + 2, 最右))
       myRng.Select
       Selection.ClearContents
       For Each sp In ActiveSheet.DrawingObjects
          If Not Intersect(Range(sp.TopLeftCell, sp.BottomRightCell), myRng) Is Nothing Then
            sp.Delete
          End If
       Next sp
       Set myRng = Nothing
       Set sp = Nothing
       '二日目の登録データをコピー
       Sheets("便登録").Select
       Range(Cells(Index * 3 + 2, 9), Cells(Index * 3 + 2, 最右)).Copy
       Sheets("指示書").Select
       Cells(lbn + 2, 9).Select
       ActiveSheet.Paste
    End If
    Worksheets("指示書").Activate
 End Sub
 Function get_Obj最左右列(ByVal rng As Range, ByVal LR As Long) As Long
    'LR　取得する列番号の種類　1　最左列　2　最右列
 '
    Dim rng1 As Range
    Dim st() As Long
    Dim i As Long
    Dim sp As Object
    Dim 列(1 To 2) As Variant '1 セル列 2 図形列
    On Error Resume Next
    Set rng1 = rng.SpecialCells(xlCellTypeConstants)
    i = 0
    For Each sp In rng.Parent.DrawingObjects
      If Not Intersect(Range(sp.TopLeftCell, sp.BottomRightCell), rng) Is Nothing Then
          i = i + 1
          ReDim Preserve st(1 To i)
          st(i) = IIf(LR = 1, sp.TopLeftCell.Column, sp.BottomRightCell.Column)
      End If
    Next sp
    get_Obj最左右列 = 0
    列(1) = False
    列(2) = False
    If Not rng1 Is Nothing Then
       列(1) = IIf(LR = 1, rng1.Cells(1).Column, rng1.Cells(rng.Count).Column)
    End If
    If i <> 0 Then
       If LR = 1 Then
          列(2) = Application.Min(st())
       Else
          列(2) = Application.Max(st())
       End If
    End If
    If LR = 1 Then
       get_Obj最左右列 = Application.Min(列())
    Else
       get_Obj最左右列 = Application.Max(列())
    End If
    Erase 列()
 End Function

 Private Sub CommandButton1_Click()
    Call Kihondosa_Click_Sub(1)
    Unload Me
 End Sub

 ところで

       Set myRng = Range(Cells(lbn, 最左), Cells(lbn, 56))
       myRng.Select
       Selection.ClearContents
       For Each sp In ActiveSheet.DrawingObjects
          If Not Intersect(Range(sp.TopLeftCell, sp.BottomRightCell), myRng) Is Nothing Then
              sp.Delete
          End If
       Next sp

 ここは、本当にこれでよいのですか？
 仮に最左が30だとすると、実行前に列10辺りに値があってもクリアされませんが・・・。

 それでよいという仕様ならよいのですが・・・・。

 ichinose

 追伸
 >擬似への脱却を読んでいますが・・・
 これは、配列コントロールを実現以外にも色々学べるのでお奨めです。

 前投稿のコ－ドについて

 今回の場合、同じような処理が複数ないか？
 「因数分解の鉄則に共通項をくくれ」というのがあったのを覚えていますか？
 あれに近いです。ただ、括っても独立した機能を持てないと別プロシジャーには、
 できないのですが・・・・。

 というのが　着眼点でした。

 すると、指定セル範囲内にあるセルの値、図形の中で最左列又は、最右列を
 求めている処理コードが殆ど同じで、機能として独立しているので
 ここの箇所を別プロシジャーにしました。

 get_Obj最左右列(ByVal rng As Range, ByVal LR As Long)

 機能

 指定セル範囲内にあるセルの値、図形の中で最左列又は、最右列を
 求める

 パラメータ　rng　最左又は、最右列を求めるセル範囲
            LR   取得指示　1　　最左列　2　最右列

 Output     get_Obj最左右列 　　　最左列又は、最右列
 　　　　　　尚、0の場合､　指定セル範囲にデータ及び図形はなし

 こんな機能を持つプロシジャーを作ることができました。

 でも、まだ同じような処理がありますよね？

 これを機能を分割できたり、又は、繰り返し処理に直せそうですが、
 そうすると、Kihondosa_Click_Subが半分ぐらいになるかもしれませんよ！！

 これは、検討してみてください。

 ichinose

ichinose様

　再三再四ご教授いただき、誠にありがとうございました。
常に「共通項をくくる意識」が大事なのですね。再度熟読して
勉強させていただきます(FunctionとかGetとか良く分かって
おりません･･･)。　それと、構造化プログラミング、
一度勉強してみます。

　仕様の件につきましてはこれでOKです。この運行指示書は
I列からBD列で24時間の30分枠(ひとつのセルが30分)で構成
されており、登録している便の最左が昼の時間帯(Column数が大、
AGからBD)から始まる場合が多く、終わりが翌日の夜中や朝の
時間帯(Column数が小、IからAF)になるため、最左の左側は
データ(前日の後半データ)を残す必要があるためです。

コメント返信：

[ 一覧(最新更新順) ]

[[20120616162440]] 『リストボックスがVBA実行で消える』（しんぽん） ページの最後に飛ぶ

[[20120616162440]]　『リストボックスがVBA実行で消える』（しんぽん）　ページの最後に飛ぶ