• ベストアンサー
  • すぐに回答を!

VBAのループ処理について

お世話になっております。 VBAのループについて教えていただきたいです。 更新ボタンを押した際に自動で計算されるプログラムを組んでおります。 計算のモジュールは「Module_g.InputCalc」で引数は(ActiveCell.Row, "支出"または"粗利益")で呼ぶことができます。 現在のコードだと粗利益の部分も支出の計算で入ってしまうため、粗利益に入ったら粗利益の計算がされるようにしたいです。 その時の判定の取り方を教えていただきたいです。 また、支出・粗利益の中の項目は追加していくことがあります。 コード Sub DateUpdate() With Sheets("HOME") Dim i As Integer For i = 7 To .Cells(Rows.Count, 1).End(xlUp).Row Call Module_g.InputCalc(i, "支出") Next End With End Sub

共感・応援の気持ちを伝えよう!

  • 回答数3
  • 閲覧数63
  • ありがとう数0

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

  • ベストアンサー
  • 回答No.1
  • kkkkkm
  • ベストアンサー率58% (893/1526)

単純に考えると Dim i As Integer mStr = "支出" For i = 7 To .Cells(Rows.Count, 1).End(xlUp).Row If .Cells(i, 1).Value = "粗利益" Then mStr = "粗利益" End If Call Module_g.InputCalc(i, mStr) Next End With

共感・感謝の気持ちを伝えよう!

関連するQ&A

  • エクセルVBA 二回目の処理でエラーが。。

    お世話になります。 今回は下記のコードですが、一回目の処理は実行されますが 二回目になるとエラーになります。 Findが悪さしているのは分かっているのですが、解決方法が分かりません。 宜しくお願い致します。 '// 非対象相手先にチェックを付ける作業 With Sheets("非対象") For Each CRR In .Range("A2:A" & .Cells(Rows.Count, 1).End(xlUp).Row) If CRR = TG Then Serc = .Cells(CRR.Row, 2) Cells(Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row).Find(Serc).Row, 36) = 0 End If Next End With 変数の宣言はちゃんと出来てます。 一回目のForではエラーも出る事なく実行されます。 しかし、二回目ではWithが設定されてない的なエラー表示がされます。

  • VBAでのエラー対処について

    現在仕事でVBAと悪戦苦闘しています。 下記のマクロを実行すると、実行時エラー'13':型が一致しません。 と表示されます。 初心者で対処法がわかりません。 よろしくお願いします。 Sub Macro1() dat = InputBox("検索値") Range("A1").Activate Cells.Find(What:=dat, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _ xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _ , MatchByte:=False, SearchFormat:=False).Activate gegyo = ActiveCell Do Cells.FindNext(After:=ActiveCell).Activate If dat = ActiveCell Then If gegyo = ActiveCell.Row Then End Rows(ActiveCell.Row - 1 & ":" & ActiveCell.Row - 1).Delete Shift:=xlUp Range("A" & ActiveCell.Row - 1).Activate Rows(ActiveCell.Row + 1 & ":" & ActiveCell.Row + 1).Delete Shift:=xlUp Rows(ActiveCell.Row & ":" & ActiveCell.Row).Delete Shift:=xlUp End If gegyo = ActiveCell.Row Loop End Sub

  • vba エクセル

    2行目から、最終行までEmptyにしたいのにならないです。 1行目はフィールド行なのに、そのままにしたいのですが 2行目から最終行は空白にしたいです。 なので Sub TEST() With Sheets("log") lastRow = .Cells(.Rows.Count, "b").End(xlUp).Row LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column .Range(.Cells(2, LastCol), .Cells(lastRow, LastCol)) = Empty End With End Sub としたのですが、何も起こりません。 lastRowは100、LastColは5なのですが、 このマクロを実行しても何も起こらないです。 なぜでしょうか?

その他の回答 (2)

  • 回答No.3

VBAというより最も単純なひとつの手法は、 関数の中から参照できる条件分岐用のグローバル変数(バイナリフラグ)を用意しておくようにします。 計算処理を速くしたければ、コードは冗長になりますが似たようなループを2つ作りループの前で分岐させます。 コードの見通しをよくしたければ、ループ内に分岐を入れて計算させます。 再利用性(編集性)がいいのは後者ですが、トータルパフォーマンスがいいのは、前者のループをそれぞれ単純関数化してサブルーチンで呼び出す感じがメインソースが見やすくなると思います。

共感・感謝の気持ちを伝えよう!

  • 回答No.2
  • imogasi
  • ベストアンサー率27% (4558/16318)

そういうことになるのは何の不思議もない。当然。 しかし画像だけでは、データの状況・内容がわからない。 特に説明が必要なのは、A列の支出行などは、セル結合がされているのか。 それなら、それを頼りにする方法もあるが。 上の行から順次処理すべきなのかどうかもよくわからない。 要するに質問の説明が不十分なんだ。 それに初心者は見てくれがよいので、よくやるが、VBAなど使うときは、セル結合をしていると、処理が面倒だということが身に染みる。 ーーーー 下記を参考にして、考えてコードを組んだら。 例データA2:B10 行が第2-5行、6-7行、8-10行が結合されているとする。 項目1が「支出」、aが「〷費」に当たる。下記の a-iはB列データです。 項目1a   b    c   d 項2  e   f 項目3 g   h   i ーーー 標準モジュール Sub test01() Lr = Range("A1000").End(xlUp).Row i = 2 p1: If i > Lr Then Exit Sub If ActiveSheet.Cells(i, 1).MergeCells = True Then m = ActiveSheet.Cells(i, 1).MergeArea.Rows.Count MsgBox Cells(i, "A") MsgBox m ’---費目の把握 For j = i To i + m - 1 MsgBox Cells(j, "B") Next j End If i = i + m GoTo p1 End Sub

共感・感謝の気持ちを伝えよう!

関連するQ&A

  • VBAでの処理分岐方法を教えてほしいです

    VBAの分岐処理で悩んでおります。 誰かお助けお願いします。 A列に昇順で番号があります。 1 2 4 4 5 6 9 欠番や重複した数値があります。 やりたいことは欠番箇所に行を挿入し、連番にしたいです。 この例で言うと、3行目に1行を挿入し番号を3と入れる、6行目に2行挿入し7,8と連番にする。 連番になった後に、重複した数値に色を付けます。 以下私が作成したコードです。callで呼び出す予定です。 Sub 欠番判定数式() Dim i As Integer For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row Cells(i, 3) = "=if(iserror(if(A" & i & "-A" & i - 1 & ">1,""○"","" "")),"""",if(A" & i & "-A" & i - 1 & ">1,""○"","" ""))" Next End Sub Sub 行挿入() Dim c As Range, Target As Range For Each c In Range("C2:C" & Cells(Rows.Count, 1).End(xlUp).Row) If c = "○" Then If Target Is Nothing Then ''(1) Set Target = c Else Set Target = Union(Target, c) ''(2) End If End If Next c If Not Target Is Nothing Then Target.Select Selection.EntireRow.Insert , copyorigin:=xlFormatFromLeftOrAbove End Sub Sub 空白連番入力() Dim i As Integer For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row If Cells(i, 1) = "" Then Cells(i, 1) = (Cells(i, 1).Offset(1, 0).Value) - 1 End If Next End Sub Sub 番号重複確認() Dim i As Integer For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row If Application.WorksheetFunction.CountIf(Range("$A$2:$A$" & Cells(Rows.Count, 1).End(xlUp).Row), Range("A" & i)) <> 1 Then Cells(i, 1).Interior.ColorIndex = 3 End If Next End Sub このコードを順に全て実行した時、1回目の処理で3行目と5行目に行挿入、そして番号が3と7と入力され連番に色が設定されます。 再度「欠番判定数式」を行い、次は8行目に行挿入し8と連番を入力させ処理を繰り返しさせたいです。 欠番は例として最高2個にしてますが、これから2個以上の可能性もあります。 一度全処理終了後、再度最初の処理(欠番判定数式)に戻り、欠番がある場合は行挿入させという処理を行わせ、欠番がない場合は次の処理に進めるという分岐方法を教えてほしいです。 よろしくお願いいたします

  • VBA 変数について

    下記コードにおける変数rは、具体的にどういう事を意味するのでしょうか? よろしくお願いします。 Dim r As Long With Worksheets("Steet1") r=.Cells(.Rows.Count,"a").End(xlUp).Row

  • EXCEL VBA 早く処理をする

    よろしくお願いします 下の構文を標準モジュールに書き込み、callで実行しているのですが 処理に時間がかかります。 処理を早くする方法と構文の簡素化のご教示をお願いします。 Application.ScreenUpdating = False For i = 1 To 12 With Worksheets(i) .Select LastRow = .Range("A150").End(xlUp).Row + 1 .Range("A8:G" & LastRow).Sort Key1:=Range("A8"), order1:=xlAscending .Range("G8:G" & LastRow - 1).Formula = "=G7+E8-F8" LastRow = .Range("A150").End(xlUp).Row + 1 .Range("A" & LastRow).Select Dim EndRow As Long EndRow = .Range("A" & Rows.Count).End(xlUp).Row Cells(Rows.Count, 1).End(xlUp).Offset(1, 3) = .Name & "合計" Cells(Rows.Count, 1).End(xlUp).Offset(1, 4) = Application.WorksheetFunction.Sum(Range("E7:E" & EndRow)) Cells(Rows.Count, 1).End(xlUp).Offset(1, 5) = Application.WorksheetFunction.Sum(Range("F7:F" & EndRow)) Cells(Rows.Count, 1).End(xlUp).Offset(2, 3) = "前月繰越" Cells(Rows.Count, 1).End(xlUp).Offset(2, 4) = .Range("G7") Cells(Rows.Count, 1).End(xlUp).Offset(2, 5) = "" Cells(Rows.Count, 1).End(xlUp).Offset(3, 4) = "" Cells(Rows.Count, 1).End(xlUp).Offset(3, 3) = "次月繰越" Cells(Rows.Count, 1).End(xlUp).Offset(4, 3) = "合計" Cells(Rows.Count, 1).End(xlUp).Offset(3, 5) = Cells(Rows.Count, 1).End(xlUp).Offset(2, 4) + Cells(Rows.Count, 1).End(xlUp).Offset(1, 4) - Cells(Rows.Count, 1).End(xlUp).Offset(1, 5) Cells(Rows.Count, 1).End(xlUp).Offset(4, 4) = Cells(Rows.Count, 1).End(xlUp).Offset(2, 4) + Cells(Rows.Count, 1).End(xlUp).Offset(1, 4) Cells(Rows.Count, 1).End(xlUp).Offset(4, 5) = Cells(Rows.Count, 1).End(xlUp).Offset(3, 5) + Cells(Rows.Count, 1).End(xlUp).Offset(1, 5) Cells(Rows.Count, 1).End(xlUp).Offset(1, 6) = "" Cells(Rows.Count, 1).End(xlUp).Offset(2, 6) = "" Cells(Rows.Count, 1).End(xlUp).Offset(3, 6) = "" Cells(Rows.Count, 1).End(xlUp).Offset(4, 6) = Cells(Rows.Count, 1).End(xlUp).Offset(0, 6) .Range("C7").End(xlDown).Select Selection.Offset(4, 2).Borders(xlEdgeTop).Weight = xlHairline Selection.Offset(4, 2).Borders(xlEdgeBottom).LineStyle = xlDouble Selection.Offset(4, 3).Borders(xlEdgeTop).Weight = xlHairline Selection.Offset(4, 3).Borders(xlEdgeBottom).LineStyle = xlDouble Selection.Offset(4, 4).Borders(xlEdgeTop).Weight = xlHairline Selection.Offset(4, 4).Borders(xlEdgeBottom).LineStyle = xlDouble Selection.Offset(0, 2).Borders(xlEdgeTop).Weight = xlHairline Selection.Offset(0, 2).Borders(xlEdgeBottom).LineStyle = xlContinuous Selection.Offset(0, 2).Borders(xlEdgeBottom).Weight = xlThin Selection.Offset(0, 3).Borders(xlEdgeTop).Weight = xlHairline Selection.Offset(0, 3).Borders(xlEdgeBottom).LineStyle = xlContinuous Selection.Offset(0, 3).Borders(xlEdgeBottom).Weight = xlThin Selection.Offset(0, 4).Borders(xlEdgeTop).Weight = xlHairline Selection.Offset(0, 4).Borders(xlEdgeBottom).LineStyle = xlContinuous Selection.Offset(0, 4).Borders(xlEdgeBottom).Weight = xlThin End With Next i Application.ScreenUpdating = True

  • アプリケーションまたはオブジェクト定義のエラーです

    データを入力するシート「input]、データを格納するシート 「data」とがあり、 新規のレコードを追加入力するために 新規入力ボタン(CommandButton2)を作成しましたが、 実行しようとすると、表記のエラーが出てしまします。 コードの確認、とそして、どこがいけないのかをご指摘いただけないでしょうか?どうかよろしくお願いいたします。 以下コードです。 Private Sub CommandButton2_Click() '新規入力 Dim row As Integer row = Sheets("data").Cells(Rows.Count, 2).End(xlUp).Offset(1) Sheets("data").Cells(row, 2).Value = Sheets("data").Cells(row - 1, 2).Value Range("AL1") = Sheets("data").Cells(row, 2).Value End Sub

  • インプットボックスのキャンセル処理

    インプットボックスのキャンセルを押したときに「型が一致しません」というエラーがでてしまいます。いろいろ調べてみてはいるのですが分かりません。教えて下さい。 Sub 指定した行数を挿入() Dim TopRow As Integer, CntRow As Integer, InstRows As Integer Dim i As Integer, ii As Integer, n As Integer Sheets("Sheet1").Select Rows("7:7").Select TopRow = ActiveCell.Row CntRow = Selection.Rows.Count n = InputBox("行数を入力して下さい。", "指定した行の挿入") If n = "" Then Exit sub End if InstRows = n For i = 1 To CntRow Rows(TopRow + (i - 1) * (InstRows + 1)).Select For ii = 2 To InstRows Selection.EntireRow.Insert Next ii Next i End Sub

  • VBA シートがなかったら「シートがない」と表示

    P1セルに「テスト」の名称を付ける。 P2セルにVLOOKUP計算式を入れる。最後尾までオートフィルでコピー。 といったコードです。 Sub テスト() &#160;Range("P1").Select &#160;&#160;&#160; ActiveCell.FormulaR1C1 = "テスト" nLast = Cells(Rows.Count, 1).End(xlUp).Row &#160;&#160;&#160; Range("P2:P" & nLast).Formula = "=VLOOKUP(K2,履歴!D:E,2,0)" End Sub もし「履歴」というシートがなかったら、「シートがありません」というメッセージウィンドウを」表示したいです。 https://oshiete.goo.ne.jp/qa/1043563.html を参考に Sub テスト() On Error GoTo err_handle &#160;Range("P1").Select &#160;&#160;&#160; ActiveCell.FormulaR1C1 = "テスト" nLast = Cells(Rows.Count, 1).End(xlUp).Row &#160;&#160;&#160; Range("P2:P" & nLast).Formula = "=VLOOKUP(K2,履歴!D:E,2,0)" err_handle: If Err = 9 Then MsgBox "シートAAAが存在しません。" Exit Sub End If End Sub と記述しましたが、エラーメッセージは表示しませんでした。 どのように追記したら良いでしょうか? 宜しくお願いします。

  • VBAについて

    現在マクロ勉強中です。 教えて頂きたいのは、登録ボタンで指定セルの台帳への転記する方法です。 Private Sub cmdToroku_Click() Dim myrow As Integer Option Explicit With ActiveSheet If .Range("A4").Value = "" Then myrow = 1 Else myrow = .Range(Cells(.Rows.Count, 1).End(xlUp).Address).Row + 1 End If .Cells(myrow, 1).Value = TextBox1.Value End With End Sub 上記ですと、開いているシートのA1に入力されてしまいます。 別シートへ転記したい場合どのあたりを修正すればよいのでしょうか? お力お借りできれば幸いです。

  • 処理速度を早くする

    処理速度を早くする よろしくお願いします。 下の構文で処理するのに5,6秒掛かります。 もっと早く処理をさせる方法をお教えください。 Private Sub 消去_Click() Application.ScreenUpdating = False Dim k As Integer Dim s As Integer With Worksheets("予定情報") k = 1 ActiveCell.Offset(0, k).Value = Temp For s = 0 To 30 ActiveCell.Offset(0, 0 + s).Delete Shift:=xlUp Range("A200:M204").Borders.LineStyle = True Next End With Application.ScreenUpdating = True End Sub

  • VBA 任意のシートからコピーを始める。

    教えてください。 全てのシートをコピーして一つのシートにまとめるプログラムシートを作成しました。 1番目のシートからコピーを始める場合は For i = 2 To Worksheets.Count 2番目のシートからコピーを始める場合は For i = 3 To Worksheets.Count とすればよいのですがこれだといちいちモジュールコードを出して数字を変更しなければならず面倒です。 そこでユーザーフォームのコンボボックスに任意の数字を入れてクリックを押せば希望するシートからコピーを始めるプログラムを作成してみましたがうまくいきません。どなたか教えてくださいませんか。 Sub matome() Dim i As Integer Dim lRow As Long, lCol As Long, lRow2 As Long, lRow3 As Long, SNo As Integer '----何番目からコピーを始めるかを決定します With UserForm2 SNo = .ComboBox1.value End With For i = 1 + SNo To Worksheets.Count With Worksheets(i) lRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1 lCol = .Cells(1, Columns.Count).End(xlToLeft).Column '----シートのデータが2行以上の場合にコピーします If lRow >= 2 Then lRow2 = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1 If lRow2 < Worksheets(1).Cells(Rows.Count, 5).End(xlUp).Row + 1 Then lRow2 = Worksheets(1).Cells(Rows.Count, 5).End(xlUp).Row + 1 .Activate .Range(Cells(2, 1), Cells(lRow, lCol)).Copy Worksheets(1).Cells(lRow2, 1) End If End With Next i

  • 二つのマクロで一気に処理したい

    以下のようなことができるのかお伺い致します。よろしくお願い致します。  やりたいこと   ※ 前提として、sheet1にすでにA列に通し番号で奇数の数字が入っている。    1.sheet1からsheet2へコピペーストする。しかし、A列からO列のすべてにデータがあった場合のみコピー貼り付けさせたい。     (前提で示したように、A列に通し番号で奇数の数字が入っていて、A列のみ数字があり、以外が空欄の行があるため)    2.下記のコピー貼り付けのコードと重複削除のコードを合体させて、一つの処理で動かしたい。 Sub コピー貼り付けつけ()  'コピー貼り付けつけのコード Dim lastRow As Long 'Sheet1のA3から最終行までをコピー With Sheets("sheet1") .Range("A3:O" & .Cells(Rows.Count, "A").End(xlUp).Row).Copy End With 'Sheet2のA列の最終行の次の行に貼付け Sheets("sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial Application.CutCopyMode = False End Sub Sub 重複データを一括削除する() ' Macro1 Macro Dim i As Long, lastRow As Long, myRng As Range LastRow = Cells(Rows.Count, "A").End(xlUp).Row For i = 1 To lastRow - 1 If WorksheetFunction.CountIf(Range(Cells(i + 1, "O"), Cells(lastRow, "O")), Cells(i, "O")) > 0 Then If myRng Is Nothing Then Set myRng = Cells(i, "O") Else Set myRng = Union(myRng, Cells(i, "O")) End If End If Next i If Not myRng Is Nothing Then myRng.EntireRow.Delete End If End Sub