[[20050205112121]]　『vbaで入力規則のリスト・・・。』（miu）　ページの最後に飛ぶ

『vbaで入力規則のリスト・・・。』（miu）

 いつも大変お世話様になっております。

 質問　A列で入力規則のリスト選択ができるようになってるのですが
       選択して入力された文字数が6文字以下はフォントサイズを11
       ７文字以上はフォントサイズ8で文字を折り返して全体を表示するように
       VBAで設定しようと下記の様なプログラムを作ってみたのですが
       うまくいきません。
       文字をキーボードから打ち込んで入力するとうまくいくのですが
       リストからの選択だとうまくいきません。
       良い方法があったらおしえてください。
       宜しくお願い致します。

 Private Sub Worksheet_Change(ByVal Target As Range)

    Dim r As Long
    r = Target.Row

        If Len(Cells(r, 1)) <= 6 Then
                   Cells(r, 1).Font.Size = 11

        ElseIf Len(Cells(r, 1)) >= 7 Then
                   With Cells(r, 1)
                       .Font.Size = 8
                       .WrapText = True
                   End With
        End If

 End Sub

 どのようにうまくいかないのですか？
 イベントは発生していますか？

  (INA)

 失礼します。
 試したら特に問題は無いようでしたけど、以下ではどうですか。
　
        If Len(Cells(r, 1)) <= 6 Then
            With Cells(r, 1)
                .Font.Size = 11
                .WrapText = False
            End With
        Else
            With Cells(r, 1)
                .Font.Size = 8
                .WrapText = True
            End With
        End If

 ※7文字や8文字ぐらいのときは、フォントが小さくなるので折り返しはしないと思いますが。

 （川野鮎太郎）

 (miu)
 すみません、自分の条件を簡略化して質問させていただいたのですが
 この質問内容だとうまくいっちゃうんですね。。。
 実は、以前ここで教えて頂きました入力規則のリスト設定

[[20041206151442]]『入力規則のリストに自動で追加したい』（miu）

 がされてまして下記のようなプログラムになってます。
 この場合だと選択しても何も変わらないのです。
 下記にそのプログラムを書き込んでみます。
 z列にリスト候補がありまして、K列（L列と結合してます。）でリスト選択して
 その際にフォントの変更をしたいです。
 Private Sub Worksheet_Change(ByVal Target As Range)

     Dim MyRow As Long 
     Dim MyRange As Range 
     Dim MyC As Double   
     Dim MyCount As Long
     Dim r11 As Long
 　　　　
　　　　select case target.column
　　　
      　　　Case 11, 12

　 Select Case Target.Row

                Case 5 To 34, 44 To 73, 83 To 112, 122 To 151

                    '入力規則のリスト追加(m列が選択欄、z列がリスト範囲欄）
                    MyRow = Range("z1").End(xlDown).Row      'z1の最下行の行番号をMyRowに代入
                    Set MyRange = Range("z1").Resize(MyRow, 1)   'ba1セルをMyRow行だけ範囲を広げたものをMyRangeに代入
                    On Error GoTo ErrorHandler                   'エラーが出たら、ErrorHandler:（エラー処理ルーチン）から処理を始める
                    MyC = Application.Match(Target.Value, MyRange, 0)  'VBAでワークシート関数を使うために、Matchの前にApplication.を付ける。
                    Exit Sub                                 'Match関数でエラーが出ないってことは、k列に入力した値がz列にあるので処理を抜ける

                    ErrorHandler: '上で書いたようにMatch関数でエラーが出るってことは、k列に入力した値がz列に無いので以下の処理を行う
                    Cells(MyRow + 1, 26).Value = Target.Value 'z列の最終行の1行下に入力した値を入れる

                    r11 = Target.Row

                    If Len(Cells(r11, 11)) <= 6 Then
                       Cells(r11, 11).Font.Size = 11

                    ElseIf Len(Cells(r11, 11)) >= 7 Then
                           With Cells(r11, 11)
                                    .Font.Size = 8
                                    .WrapText = True
                           End With
                    End If                 
            End Select
        End Select
 end sub

 原因が判りました。
 Z列に該当文字がある場合はExit Subで処理を抜けているからです。
　
Private Sub Worksheet_Change(ByVal Target As Range)
Dim MyRow As Long
Dim MyRange As Range
Dim MyC As Double
Dim MyCount As Long
Dim r11 As Long
Const MyCol As Long = 11  '11列目（K列）
r11 = Target.Row
Select Case Target.Column
    Case 11, 12
Select Case Target.Row
    Case 5 To 34, 44 To 73, 83 To 112, 122 To 151
        '入力規則のリスト追加(m列が選択欄、z列がリスト範囲欄）
        MyRow = Range("z1").End(xlDown).Row      'z1の最下行の行番号をMyRowに代入
        Set MyRange = Range("z1").Resize(MyRow, 1)   'ba1セルをMyRow行だけ範囲を広げたものをMyRangeに代入
        On Error GoTo ErrorHandler                   'エラーが出たら、ErrorHandler:（エラー処理ルーチン）から処理を始める
        MyC = Application.Match(Target.Value, MyRange, 0)  'VBAでワークシート関数を使うために、Matchの前にApplication.を付ける。
        GoTo MyFont
        'Exit Sub                                 'Match関数でエラーが出ないってことは、k列に入力した値がz列にあるので処理を抜ける
ErrorHandler:                     '上で書いたようにMatch関数でエラーが出るってことは、k列に入力した値がz列に無いので以下の処理を行う
        Cells(MyRow + 1, 26).Value = Target.Value 'z列の最終行の1行下に入力した値を入れる
    End Select
End Select
MyFont:
    With Target
        If Len(Target.Value) <= 6 Then
            .Font.Size = 11
            .WrapText = False
        Else
            .Font.Size = 8
            .WrapText = True
        End If
    End With
End Sub

 （川野鮎太郎）

 川野さん、出来ました。ありがとうございます。
 ただ、Z列、K列で文字を削除した場合
 If Len(Target.Value) <= 6 Thenで実行時エラー１３、型が一致しませんとでてしまいます。
 どこを直せばいいでしょうか？

 ※すみません、この後のレスは少し遅れてしまいます。。。
 (miu)

 Select Caseではなく、IFで抜けるようにしました。
　
Private Sub Worksheet_Change(ByVal Target As Range)
Dim MyRow As Long
Dim MyRange As Range
Dim MyC As Double
If Application.Intersect(Target, _
    Range("K5:L34,K44:L73,K83:L112,K122:L151")) Is Nothing Then Exit Sub
If Target.Count > 1 Then Exit Sub
If IsEmpty(Target.Value) And IsEmpty(Target.Offset(0, 1).Value) Then Exit Sub
    '入力規則のリスト追加(K列が選択欄、Z列がリスト範囲欄）
    MyRow = Range("z1").End(xlDown).Row      'Z1の最下行の行番号をMyRowに代入
    Set MyRange = Range("Z1").Resize(MyRow, 1)   'Z1セルをMyRow行だけ範囲を広げたものをMyRangeに代入
    On Error GoTo ErrorHandler                   'エラーが出たら、ErrorHandler:（エラー処理ルーチン）から処理を始める
    MyC = Application.Match(Target.Value, MyRange, 0)  'VBAでワークシート関数を使うために、Matchの前にApplication.を付ける。
    GoTo MyFont
ErrorHandler:                     'Match関数でエラーが出るってことは、K列に入力した値がZ列に無いので以下の処理を行う
    Cells(MyRow + 1, 26).Value = Target.Value 'z列の最終行の1行下に入力した値を入れる
MyFont:
    With Target
        If Len(Target.Value) <= 6 Then
            .Font.Size = 11
            .WrapText = False
        Else
            .Font.Size = 8
            .WrapText = True
        End If
    End With
End Sub

 （川野鮎太郎）

 お返事大変遅くなりまして申し訳ありませんでした。
 早速試してみました所、うまく作動しました。
 いつも本当に助かっております。
 ありがとうございました。

 ちなみに、selectからifにしたことにより、どう変わったのかいまいちわからなかったのですが
 またご説明いただいても宜しいでしょうか？（いつも、いつもすみません。。。）
 宜しくお願いします。
 (miu)

 Select Case　でやっても良かったんですけど、対象外の列を条件分岐するのには
 今回の場合IFの方が分岐させやすかったからです。(^_^A;

 （川野鮎太郎）

 わかりました。ありがとうございます。m(__)m
 （miu）

コメント返信：

[ 一覧(最新更新順) ]

[[20050205112121]] 『vbaで入力規則のリスト・・・。』（miu） ページの最後に飛ぶ

[[20050205112121]]　『vbaで入力規則のリスト・・・。』（miu）　ページの最後に飛ぶ