質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

90.84%

  • VBA

    1561questions

    VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

VBA 条件分岐 while文?

解決済

回答 5

投稿 編集

  • 評価
  • クリップ 0
  • VIEW 188

nashitake

score 6

 VBAで背景色をつけたい。エクセルの範囲を指定せずに、複数の条件分岐を実現したい

ここに質問の内容を詳しく書いてください。
かなり長文になると思いますが、色々試した結果、手詰まりになっているので質問します。
イメージ説明
L列に行いたい処理を記載しているのですが、コードを書いて実行した結果、
イメージ説明
こうなってしまいます。
実際に行いたい処理が
イメージ説明
です。
そして、先輩には、仕事では特定のセル範囲のみに処理を表示させることはないから、セル範囲を指定せずに条件が合致している間は、処理を行えるようにしとほしいといわれていますが、なかなかうまくいきません。

 該当のソースコード

'''
Sub Ara()
Dim a As Integer
Dim b As Integer

For a = 3 To 32
For b = 8 To 9

If Cells(a, 7) <> "" Then
Cells(a, 8) = Cells(a, 7) + 1
Cells(a, 9) = Cells(a, 7) + 2

ElseIf Cells(a, b) Mod 2 = 0 And Cells(a, b) <> "" Then
Cells(a, b).Interior.ColorIndex = 3

End If
Next b
Next a

End Sub
'''

 試したこと

上記はfor文でセル範囲を指定しています。セル範囲を指定せずに条件に合致している間繰り返すということなのでwhile文を使用したのですが、うまくいきませんでした。

 補足情報

文章が分かりにくいことは承知しています。
もし、ご回答いただけたら、助かります。

修正依頼がございましたので、追記致します。
「複数の条件分岐」という言葉では分からないとの事、言葉が足りませんでした。すみません。

要件といいますか実現したいことは、
条件1 G3~32に値が入っていたら、
処理(例 G3の値に+1したものをH3に、G3の値に+2したものをI3に)G4以降も同じ
条件2 値が入っていないところは
処理 空白
条件3 セルに偶数の値のみが入っている場合
処理 セルの背景色を赤色

以上をセル範囲を指定せずに、条件に当てはまる場合は繰り返す処理をしたいということです。

上記の文章でよいかは個人的に不安が残りますが、追記とさせていただきます。

  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

質問への追記・修正、ベストアンサー選択の依頼

  • mts10806

    2018/05/05 12:39

    コードはコードブロック```で囲ってください。また、「複数の条件分岐」というのは?要件として文章で補足で入れてください。

    キャンセル

回答 5

checkベストアンサー

+1

すでに、いろいろな方法がでてますが、一例として。

Sub Ara()
    Dim r As Range, c As Range, i As Long

    Set r = Range(Range("G3"), Cells(Rows.Count, 7).End(xlUp))    '条件のセル範囲
    r.Offset(, 1).Resize(, 2).Clear    '処理対象のセル範囲の値と書式のクリア

    Set r = r.SpecialCells(xlCellTypeConstants)    '値のあるセルのみ取得
    For Each c In r
        For i = 1 To 2
            With c.Offset(, i)
                .Value = c.Value + i
                If .Value Mod 2 = 0 Then .Interior.ColorIndex = 3
            End With
        Next
    Next
End Sub

追記

ワークシートのイベントプロシージャを使う方法が提案されているようなので、その場合の例。

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim cell As Range
    Dim i As Long

    For Each cell In Target
        If cell.Column = 7 And cell.Row >= 3 Then
            If cell.Value <> "" And IsNumeric(cell.Value) Then
                For i = 1 To 2
                    With cell.Offset(, i)
                        .Value = cell.Value + i
                        If .Value Mod 2 = 0 Then .Interior.ColorIndex = 3
                    End With
                Next
            Else
                cell.Offset(, 1).Resize(, 2).Clear
            End If
        End If
    Next
End Sub


ただ、ユーザーの入力に逐一反応するという仕様なら、セルに式と条件付き書式を設定する方法でもいいように思います。

Cells(行,列) の絶対座標でセル位置を指定する方法と、Offsetで相対座標でセル位置を指定する方法がありますが、相対座標の場合、対象セル範囲が変更になったときも変更箇所が少なくてすみますので、私の場合はこちらで書く場合が多いです。

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2018/05/06 10:29

    ご解答ありがとうございます。トライしてみます。ありがとうございます。

    キャンセル

+1

お役に立てるかわかりませんが、
私にできる限りでコードを書いてみました。

Sub Ara()

    Dim a As Integer
    Dim row_end As Integer
    row_end = Cells(Rows.Count, 7).End(xlUp).Row

    Range(Cells(3, 8), Cells(row_end, 9)).ClearContents
    Range(Cells(3, 8), Cells(row_end, 9)).Interior.ColorIndex = 0

    For a = 3 To row_end
        If Cells(a, 7).Value <> "" Then
            Cells(a, 8).Value = Cells(a, 7).Value + 1
            If Cells(a, 8).Value Mod 2 = 0 Then
                Cells(a, 8).Interior.ColorIndex = 3
            End If
            Cells(a, 9).Value = Cells(a, 7).Value + 2
            If Cells(a, 9).Value Mod 2 = 0 Then
                Cells(a, 9).Interior.ColorIndex = 3
            End If
        End If
    Next a

End Sub

・何行使うか決まっていない場合に備えて
最終行を変数に代入してあります。
・マクロ実行の度にH列I列をクリアします。
・For-Nextのネストは不要に思えたので削りました。

セルの色付けはもっとスマートな
書き方があるような気がします。

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

+1

Sub Ara()
’型式をInteger => Longへ変更
Dim a As Long 
Dim b As Long
Dim c As Long

'最終行を取得
c = Cells(Rows.Count, 7).End(xlUp).Row

For a = 3 To c
For b = 8 To 9
If Cells(a, 7) <> "" Then
Cells(a, 8) = Cells(a, 7) + 1
Cells(a, 9) = Cells(a, 7) + 2
ElseIf Cells(a, b) Mod 2 = 0 And Cells(a, b) <> "" Then
Cells(a, b).Interior.ColorIndex = 3
End If
Next b
Next a

End Sub

提示分を、もとに「上方向に最終行を検索する」と考えました。
データの型は、データの範囲が不明なので変更しました。

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2018/05/06 11:25

    ご解答ありがとうございます。ご解答いただいた方で一番シンプルのコードだと思います。トライしてみます。

    キャンセル

+1

多分一々呼ぶのではなく、値の変更に動的に対応して欲しいってことだと思います。
標準モジュールではなく、ワークシートにイベント処理を書いてます。

Private Sub Worksheet_Activate()
    Call Worksheet_Change(ThisWorkbook.ActiveSheet.Range("G3:G32"))
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim cell As Range
    Dim targetCell As Range
    Dim i As Integer
    Dim inputValue As Long

    For Each cell In Target.Cells
        If cell.Column = 7 And cell.Row >= 3 And cell.Row <= 32 Then 'G3 ~ G32 なら
            For i = 1 To 2 'となりと、そのとなり
                Set targetCell = cell.Offset(0, i)
                If IsNumeric(cell.value) Then

                    inputValue = cell.value + i

                    targetCell.value = inputValue

                    If inputValue Mod 2 = 0 Then '偶数なら
                        targetCell.Interior.Color = RGB(255, 0, 0) '背景を赤に
                    End If
                Else
                    targetCell.value = ""
                End If
            Next i
        End If
    Next cell

End Sub

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2018/05/06 10:28

    ご解答ありがとうございます。さっそくためしてみようと思います。シートモジュールは使ったことがないので調べながらやろうと思います。

    キャンセル

+1

hihijiji様のご指摘を活かさせていただき、
シートモジュール用のコードを書いてみました。

対象とするワークシートのシートモジュールに記述してください。
VBE内の「Sheet*(Sheet*)」です。
「Module*」ではありません。

Worksheet_Change()は予約されたイベントプロシージャで、
イベントがあるたび走査します。

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim a, b, row_end As Long

    '最終行を取得
    row_end = Cells(Rows.Count, 7).End(xlUp).Row

    '入力がG列以外の場合はプローシージャを終了
    If Intersect(Target, Range(Cells(3, 7), Cells(row_end, 7))) _
    Is Nothing Then
        Exit Sub
    Else
        For a = 3 To row_end
            For b = 8 To 9
                '入力値が空白の場合の処理
                If Cells(a, 7).Value = "" Then
                    Cells(a, b).ClearContents
                    Cells(a, b).ClearFormats
                '入力があった場合の処理
                Else
                    Cells(a, b).Value = _
                    Cells(a, 7).Value + b - 7 'H列は+1、I列は+2
                    If Cells(a, b).Value Mod 2 = 0 Then
                        Cells(a, b).Interior.Color = RGB(255, 0, 0) '赤色
                    Else
                        Cells(a, b).ClearFormats '塗りつぶしなし
                    End If
                End If
            Next b
        Next a
    End If

End Sub

やはりコードをスッキリさせるためには
For~Next文は必要でした。すみませんでした。

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2018/05/06 10:26

    ご解答ありがとうございます。シートモジュールは使用したことがないので不慣れな点があると思いますが、トライしてみます。ありがとうございます。

    キャンセル

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 90.84%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

関連した質問

  • 解決済

    VBA 同じファイル内のシート間でのファイル操作について

    添付のような表があります。 右の表を、左の表の該当する欄にデータを取り込む作業です。 頻度は、月1回です。 バタバタと、他の作業をしながらの作成となるのでなるべく楽に作成したいと思

  • 解決済

    エクセル VBA  同一グラフ内で範囲が異なっているグラフ範囲を同じにしたい

    いつもお世話になっております。 エクセルのグラフの範囲一括変更について教えてください。  以前、グラフ範囲を一括で変更かける方法をマクロにて伝授していただいたのですが  そのマク

  • 解決済

    VAB 結合セルとループ

    前提・実現したいこと | 2013 | 1 | 山田 |      | 2 | 田中 |      | 3 | 佐藤 | 2014 | 1 | 山田 | 2015 | 1

  • 解決済

    VBA オブジェクトとfor each~next

    お疲れ様です。 データーを高速に処理するプログラムに改良するため、 セルをループで人る一つ見るのではなく、オブジェクト変数を使った方が高速に処理できるとのことで、オブジェク

  • 解決済

    VBA 配列

    お世話になっております。 配列について学習を進めておりますが、イマイチどのようにデーターが格納されているくな分からず、意図した処理ができない状態です。 D列に"No"が合っ

  • 解決済

    エクセル VBA 1つのセルの値を分けて、逆並びで列に配置

    教えてください。 F列2行目から例えば、 43x43x5(×は大文字のx(エックス)で代用してます。) というサイズ「縦x横x高さ」が入力されています。 これを数値ごと

  • 受付中

    VBA マルチページのカスタマイズ

    VBAを使用して、業務ソフトを作成しております。 その際、フォーム内にマルチページを作成して、その内部に必要なコマンドを配置するというやり方をしています。 マルチページを初

  • 解決済

    ExcelのVBAで金種計算表をDo While文とIf文のみで作成したい

    ExcelのVBAで金種計算表をDo While文とIf文のみで作成したいのですが、下記のプログラムを実行してもExcel自体が応答不能になってしまいます。 下記に金額を入力すると

同じタグがついた質問を見る

  • VBA

    1561questions

    VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。