• ベストアンサー

このマクロの繰り返し？

ＶＢＡ初心者です。 これを、繰り返し（入れ子）でもっと省略できますか？ Sub test() Dim retu1 As Integer retu1 = 50 Do While retu1 >= 1 Cells(retu1, retu1 + 50).Interior.ColorIndex = 9 retu1 = retu1 - 1 Loop 'ココから先をもっと簡単にしたいです！ retu1 = 50 Do While retu1 >= 1 Cells(retu1 + 1, retu1 + 50 - 1).Interior.ColorIndex = 9 retu1 = retu1 - 1 Loop retu1 = 50 Do While retu1 >= 1 Cells(retu1 + 2, retu1 + 50 - 2).Interior.ColorIndex = 9 retu1 = retu1 - 1 Loop End Sub どなたか、お願いします。

質問者が選んだベストアンサー

  • ベストアンサー
  • toshi_2000
  • ベストアンサー率30% (306/1002)
回答No.1

for i=0 to 2 retu1 = 50 Do While retu1 >= 1 Cells(retu1 + i, retu1 + 50 - i).Interior.ColorIndex = 9 retu1 = retu1 - 1 Loop next これでループ３回が１回ですみます。

nanakokko
質問者

お礼

すばらしい回答！！！ こんな回答を求めていました！！ さすが専門家サマサマです（泣）・・・ ほんとうにありがとうございました！！

全文を見る
すると、全ての回答が全文表示されます。

その他の回答 (1)

  • BLUEPIXY
  • ベストアンサー率50% (3003/5914)
回答No.2

'単に１つにまとめるといいと思います。 Sub test() Dim retu1 As Integer retu1 = 50 Do While retu1 >= 1 Cells(retu1, retu1 + 50).Interior.ColorIndex = 9 Cells(retu1 + 1, retu1 + 50 - 1).Interior.ColorIndex = 9 Cells(retu1 + 2, retu1 + 50 - 2).Interior.ColorIndex = 9 retu1 = retu1 - 1 Loop End Sub

nanakokko
質問者

お礼

ありがとうございます！！ 誠に失礼なのですが、もうちょっと、短く出来ないかなあ・・・

全文を見る
すると、全ての回答が全文表示されます。
  1. カテゴリ
  2. [技術者向] コンピューター
  3. プログラミング・開発
  4. Visual Basic

関連するQ&A

  • マクロ　日付の内容でセルを塗りつぶす

    セルに記載された日付が、『TODAY以上なら赤色』・『TODAY以下なら青色』・『それ以外なら塗り潰し無し』にしようと下記のマクロを記述しましたが、思うようになりませんでした。どうしたら治るでしょうか？御指導お願い致します。 Sub セルを色で塗りつぶす() Dim C As Integer C = 5 Do While Cells(5, C).Value <> "" With Cells(6, C) Dim Today As Date Today = Date Select Case .Value Case Is <= Today .Interior.ColorIndex = 8 Case Is >= Today .Interior.ColorIndex = 3 Case Else .Interior.ColorIndex = xlNone End Select End With C = C + 1 Loop End Sub

  • エクセルマクロを教えてください

    下記のマクロを動かすことはできるのですが、 処理が実行されると、コマンドプロンプト画面が表示されてしまいます。 自分でも色々調べたのですが、どうしてもわからないです。 どこを修正したらコマンドプロンプトが表示されずに、 処理が実行されるのか教えてください。 動作環境 OS：Windows7 アプリ：Excel2003、2010 ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝ Sub ping送信 　　Dim objWSH As Object, oEx As Object 　　Dim i As Integer 　　Dim sCmd As String 　　Dim sResult As String 　　 　　Set objWSH = CreateObject("WScript.Shell") 　　 　　For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row 　　　　sCmd = "%ComSpec% /c ping -n 1 " & Cells(i, 1) 　　　　Set oEx = objWSH.Exec(sCmd) 　　　　 　　　　Do While oEx.Status = 0 　　　　　　DoEvents 　　　　Loop 　　　　sResult = oEx.StdOut.ReadAll 　　　　 　　　　If InStr(sResult, "ラウンド トリップの概算時間") = 0 Then 　　　　　　Cells(i, 1).Interior.ColorIndex = 3 　　　　Else 　　　　　　Cells(i, 1).Interior.ColorIndex = 4 　　　　End If 　　Next ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

  • マクロ　Value=Valueで複写できない

    いつも回答して頂きありがとうございます。 たぶん基本的な質問だと思うのですが、どうしたら上手くいくのか分かりません。御指導の程よろしくお願いします。以下の記述でエラーがかかります。 『コンパイルエラー：SubまたはFunctionが定義されていません』 Worksheets("一覧").Cells(d, 5).Value = Wokrsheets("編集用一覧").Cells(e, 5).Value 記述全体 Sub TEST() Dim d As Integer Dim e As Integer Worksheets("一覧").Activate d = 3 e = 6 Do While Worksheets("一覧").Cells(d, 2).Value <> "" Worksheets("一覧").Cells(d, 5).Value = Wokrsheets("編集用一覧").Cells(e, 5).Value d = d + 1 e = e + 4 Loop End Sub

  • VBA 九九 Do While

    VBAのDo Whileステートメントを使って九九の表をつくりたいのですが、何度やっても途中で詰まり、実行に至りません。 For NextとDo untilではできたと思うのですがDo Whileがどうしてもわからなくて… どなたか助けてください。お願いします。 Sub 九九計算_for() Dim i, j As Integer For i = 1 To 9 For j = 1 To 9 Cells(i, j).Value = i * j Next Next End Sub Sub 九九計算_do_until() j = 1 Do i = 1 Do Cells(j, i).Value = i * j i = i + 1 Loop Until i = 10 j = j + 1 Loop Until j = 10 End Sub

  • ファイルオープン時のマクロが一部実行されない

    いつも回答して頂き、ありがとうございます。感謝感謝です。 ファイルオープン時にApplication.Runで３つのマクロを実行させているのですが、最後のマクロだけ実行されません。どうしてでしょうか？もしかして、前の２つで『一覧シート』を除外するマクロを実行しているからでしょうか？御指導の程宜しくお願いいたします。 1番目に実行するマクロ Sub 特定のシート以外の最終履歴と次回予定日を算出する() Dim ws As Worksheet For Each ws In Worksheets If ws.Name <> "一覧" Then If ws.Name <> "メニュー" Then Dim c As Integer c = 3 Do While ws.Cells(2, c).Value <> "" With ws.Cells(6, c) .FormulaR1C1 = "=MAX(R8C:R10000C)" If .Value = 0 Then .Value = "履歴無し" ws.Cells(7, c).ClearContents Else .Value = .Value ws.Cells(7, c) = DateAdd("d", ws.Cells(5, c), DateAdd("m", ws.Cells(4, c), DateAdd("yyyy", ws.Cells(3, c), ws.Cells(6, c)))) End If End With c = c + 1 Loop End If End If Next End Sub ２番目に実行するマクロ Sub 期限の未達と到達を色で分ける() Dim ws As Worksheet For Each ws In Worksheets If ws.Name <> "一覧" Then If ws.Name <> "メニュー" Then Dim c As Long Dim res As Variant For c = 3 To ws.Cells(7, Columns.Count).End(xlToLeft).Column If IsDate(ws.Cells(7, c)) Then If ws.Cells(7, c) > Date Then res = 8 Else res = 3 End If Else res = xlNone End If ws.Cells(7, c).Interior.ColorIndex = res Next c End If End If Next End Sub ３番目に実行するマクロ Sub 各シートの情報を一覧へ転記する() Dim d As Integer Dim retu As Integer d = 3 Do While Cells(d, 2).Value <> "" With Worksheets(Worksheets("一覧").Cells(d, 2).Value) .Activate retu = .Range("IV7").End(xlToLeft).Column .Range(Cells(7, 3), Cells(7, retu)).Copy End With With Worksheets("一覧") .Activate Cells(d, 3).PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False End With d = d + 1 Loop End Sub

  • このVBAソースのどこが間違ってるか教えてください

    Dim csp As Integer 'ストップ Dim css As Integer 'ストップorスタート Sub Quest2() If css = 0 Then css = 1 Quest2a Else cstp = 1 css = 0 End If End Sub Sub Quest2a() Sheets("Sheet1").Select Range("B1:J10").Select Selection.Interior.ColorIndex = x1None Range("a1").Select cstp = 0 Do r = 1: c = 5 For i = 0 To 15 If i < 9 Then Cells(r, c).Interior.ColorIndex = x1None r = r + 1 If i < 5 Then c = c + 1 Else c = c - 1 End If Cells(r, c).Interior.ColorIndex = 3 Else Cells(r, c).Interior.ColorIndex = x1None r = r - 1 If i < 13 Then c = c - 1 Else c = c + 1 End If Cells().Interior.ColorIndex = 3 End If 'タイミング For tm1 = 1 To 1000: For tm2 = 1 To 100: Next If cstp = 1 Then Exit For End If Next DoEvents If cstp = 1 Then Exit For End If If r = 3 And c = 5 Then Cells(r, c).Interior.ColorIndex = x1None End If Next DoEvents If cstp = 1 Then Exit Do End If Loop Cells(10, 9) = Cells(r, c) Cells(10, 9).Interior.ColorIndex = 8 End Sub

  • Excel VBA スケジュールマクロ最適化

    現在下記の様なスケジュール表を作成しています。 ・セル(14,3)から下方は"タスク"列 ・セル(14,5)から下方は"開始日"列 ・セル(14,7)から下方は"終了日"列 ・セル(14,8)から下方は"重要度"列 ・セル(11,11)から右側へ日付が連番で入っている ・開始日と終了日を入れると自動的に変更された行を取得し、開始/終了日の範囲でセルの塗り潰しを実行 ・重要度で色を変更し、"M"を入れると★マーク表示し、その右側へタスク名表示 ３つ質問があります。 (1)現在、セルの塗り潰しを行うのに下記の様に設定しているのですが、日付を入れてからセルの塗り潰しがされるまで若干時間がかかるのですが、何か他に良い方法は無いでしょうか？ (2)あと、終了日の最大値を取得して、セル(11,11)から右側へ伸びている日付行を自動調整したいのですが、方法が分からなくて困っています。 (3)VBA初心者の為、色々調べながら作っているのですが、継ぎはぎだらけなので、改善したらよいポイントなどがあれば教えて頂けると助かります。 ================================================================ Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim Gyo As Long Dim COL As Long Dim c As Integer Dim l As Integer Dim n As Integer c = 11 l = 11 Gyo = Target.Row ' 変更した行を取得 If Gyo <= 13 Then Exit Sub ' 1～13なら無視 COL = Target.Column ' 変更した列を取得 If ((COL <= 4) Or (COL >= 9)) Then Exit Sub '開始日、終了日以外は無視 ' 計算式セット自体でもイベントが発生するのでイベントを抑制 Application.EnableEvents = False '入力した条件により、セルの塗りつぶし範囲を取得 If Cells(Gyo, 5) <= Cells(11, c) Then Do Until Cells(Gyo, 5) >= Cells(11, c) c = c + 1 Loop ElseIf Cells(Gyo, 5) >= Cells(11, c) Then Do Until Cells(Gyo, 5) <= Cells(11, c) c = c + 1 Loop End If If Cells(Gyo, 7) <= Cells(11, l) Then Do Until Cells(Gyo, 7) >= Cells(11, l) l = l + 1 Loop ElseIf Cells(Gyo, 7) >= Cells(11, l) Then Do Until Cells(Gyo, 7) <= Cells(11, l) l = l + 1 Loop End If 'セルの色をクリア Rows(Gyo).Interior.ColorIndex = xlNone 'セルの塗りつぶし範囲に色を設定 If Cells(Gyo, 8) = 1 Then For n = c To l Cells(Gyo, n).Clear Cells(Gyo, n).Interior.ColorIndex = 3 Next n ElseIf Cells(Gyo, 8) = 2 Then For n = c To l Cells(Gyo, n).Clear Cells(Gyo, n).Interior.ColorIndex = 26 Next n ElseIf Cells(Gyo, 8) = 3 Then For n = c To l Cells(Gyo, n).Clear Cells(Gyo, n).Interior.ColorIndex = 5 Next n ElseIf Cells(Gyo, 8) = "M" Then Cells(Gyo, c) = "★" Cells(Gyo, 3).Copy Cells(Gyo, c + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False Cells(Gyo, 8).Select Else For n = c To l Cells(Gyo, n).Clear Cells(Gyo, n).Interior.ColorIndex = 10 Next n End If 'イベントを再開 Application.EnableEvents = True End Sub ============================================================

  • Excel　マクロ

    Private Sub Workbook_Open() Dim name As String name = "7月" '//ワークシート名----編集用（本日曜日カラー変更ロジック用----月初変更箇所） Dim week As String Dim Y As Integer Dim X As Integer '//処理(1)-(1)　すべての曜日セルの背景を白にする Worksheets(name).Range("A13:M13").Interior.ColorIndex = 19 '白 '//処理(1)-(2)　今日の曜日を取得して色を変更する week = WeekdayName(Weekday(Now), False) '今日の曜日 Y = Worksheets(name).Cells.Find(week).Row X = Worksheets(name).Cells.Find(week).Column Worksheets(name).Cells(Y, X).Interior.ColorIndex = 45 'オレンジ系の色 '//処理(2)　本日日付を取得して色を変更する Dim D As Integer D = Day(TODAY()) '本日の日付 Y = Worksheets(name).Cells.Find(D, LookAt:=xlWhole).Row X = Worksheets(name).Cells.Find(D, LookAt:=xlWhole).Column Worksheets(name).Cells(Y, X).Interior.ColorIndex = 19 ' End Sub 途中なのですが、日付を取得して色を変える というロジックを作っていて 処理(2)からを新しく付け足した時にエラーが起こりました。 内容は「SubまたはFunctionが定義されていません」です。 どうやらD = Day(TODAY())らへんでエラーになっているようなのですが どなたか分かる方教えてください(´・ω・`)(´-ω-`))ぺこり

  • エクセルマクロで教えてください

    マクロ初心者です。アドバイスをお願いします。以下のマクロですとB列の100行目までの塗りつぶしのセルのカウントは出来るのですが、シート上の全てをカウントしたいのです。１TO 100の100の部分をどう変更したら良いのか教えてください。 Sub セルの色数1() Dim I As Integer Dim Count As Integer Count = 0 For I = 1 To 100 If Cells(I, 2).Interior.ColorIndex <> xlNone Then Count = Count + 1 Next I Range("C1").Value = Count End Sub

  • エクセル2003 VBAマクロにて 背景色　白色の抽出

    エクセル２００３のマクロでセル背景色にて抽出したいのですが 背景色が白色（空白）の抽出ができません。 背景色別に　他セルに文字を自動記入したいのですが、 背景色が白（collorindex=0)の認識をしてくれません。 カラーインデックスでは、白は「0」か「2」になっているので その値でマクロを組んでも認識してくれないようです。 どのようにすればよいのでしょうか？ 以下に私（素人）のマクロ文（一部）です。ご指摘お願い致します。 Dim 行番号 As Integer 行番号 = 7 Do Until Cells(行番号, 1).Value = "" If Cells(行番号, 9).Interior.ColorIndex = 5 Then Cells(行番号, 14).Value = "3号機" 　　ElseIf Cells(行番号, 9).Interior.ColorIndex = 7 Then Cells(行番号, 14).Value = "4号機" ElseIf Cells(行番号, 9).Interior.ColorIndex = 0 Then Cells(行番号, 14).Value = "未加工" End If 行番号 = 行番号 + 1 Loop

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

あなたにピッタリな商品が見つかる！ OKWAVEセレクト

質問する