VBA繰り返し処理に追加条件を入れたい
- Excel2003を使用しております。下記の様なA～Dの内容をE～Hに生産指示伝票用にバラしてコピーしています。セット品の場合の事を考えておりませんでした。条件による分岐を行うにはどうすればよいのか御教授下さい。
- 上記のVBAだと、セット品も1としてコピーされるだけなので、セット品の場合のみ、別シートのSET品マスタから読み込める様にしたいと考えております。
- VBAについてまだまだ勉強不足ですが使いながら学んで行きたいと考えていますのでよろしくお願いいたします。
- ベストアンサー
VBA 繰り返し処理に追加条件を入れたい
Excel2003を使用しております。 下記の様なA～Dの内容をE～Hに生産指示伝票用に バラしてコピーしています。 単品の事だけを考えており、SET品の場合の事を 考えておりませんでした。 条件による分岐を行うにはどうすればよいのか御教授下さい。 Dim FromRow As Integer 'コピー前の行番号 Dim ToRow As Integer 'コピー先の行番号 Dim Num As Integer '現在転記中の残りの個数 FromRow = 2 '元の表のデータの最初の行番号 ToRow = 2 '転記先の最初の行番号 'メインループ Do While Cells(FromRow, "A").Value <> "" Num = Cells(FromRow, "D").Value '個数を取得 Do While Num > 0 Cells(FromRow, "A").Resize(2, 4).Copy Cells(ToRow, "E") 'A～C列をE列にとりあずコピー If Num >= 1 Then Cells(ToRow, "H").Value = 1 '2以上だったらコピー先の個数を1に置きかえ Else Cells(ToRow, "H").Value = Num '1未満だったらその数に置きかえ End If Num = Num - 1 ToRow = ToRow + 1 Loop FromRow = FromRow + 1 Loop 上記のVBAだと、セット品も1としてコピーされるだけなので、 セット品の場合のみ、別シートのSET品マスタから下記の様に 読み込める様にしたいと考えております。 区分 商品名 色 数量 区分 商品名 色 数量 単品 ボールペン ブルー 1 単品 ボールペン ブルー 1 単品 ボールペン レッド 2 単品 ボールペン レッド 1 SET Aセット レッド 2 単品 ボールペン レッド 1 単品 色鉛筆 ブルー 2 SET 色鉛筆 レッド 1 単品 色鉛筆 レッド 3 SET ボールペン レッド 1 SET Bセット 黒 2 SET 色鉛筆 レッド 1 SET ボールペン レッド 1 単品 色鉛筆 ブルー 1 単品 色鉛筆 ブルー 1 単品 色鉛筆 レッド 1 単品 色鉛筆 レッド 1 単品 色鉛筆 レッド 1 SET マジック 黒 1 SET ボールペン 黒 1 SET マジック 黒 1 SET ボールペン 黒 1 VBAについてまだまだ勉強不足ですが 使いながら学んで行きたいと考えていますので よろしくお願いいたします。
- hi-lite junky（@hi-lite05）
- お礼率92% (51/55)
- その他MS Office製品
- 回答数1
- ありがとう数1
- みんなの回答 （1）
- 専門家の回答
質問者が選んだベストアンサー
答えでもないので、参考です。 数量の展開とセット品の展開があるので、 それを同時に進行するやり方 数量の展開をおこなって、その後でまたループしてセット品の展開、２段階でおこなうやり方 と２通りあると思います。 後者をまずやってみて前者へ整形するのもありかと思います。 セット品の時のほかシートを参照して・・・、というのに困っていますか？。 セット品の商品情報のシートを 事前に読み込んで配列に待避しておいてから今回の編集を操作すれば、 単品はシート値そのままで展開、セット品の商品の展開は配列を見て展開、 とできるように思いますが、それに耐えうる商品数かがわかりません。 それか 存在するセット品を単品レベルに展開させておけば 今のロジックが使えるようにも思えます。 条件分岐というよりは、どのタイミングでセット品の展開をおこなうか、 そんな感じかと思います。
関連するQ&A
- Excel VBAの繰返し処理を教えて下さい
マクロを始めたばかりの初心者です。 どなたかご教示下さい。 リストから担当者社員番号をキーとして既定のシートにデータ転記し、別ファイルコピー後名前を付けて保存するというマクロを作成しています。 ご教示頂きたいのは、担当者別にファイルを作成したいのですが、 １行ごとの処理になり、無限ループでVBAが終了しません。 色々調べてみたものの、解決策が見つかりません。 どなたかご教示いただけないでしょうか。 読みにくいコードですが何卒よろしくお願い致します。 サンプルコード Sub 担当者用_個人用() Dim 行 As Integer Dim 年月 As String Dim メール行 As Integer Dim 担当者用 As String Dim 社員番号 As String Dim 社員名 As String Dim 残業対象 As String Dim 所属コード As String Dim 所属名 As String Dim 事業所コード As String Dim 事業所名 As String Dim 社員区分 As String Dim 平日時間外_m As String Dim 休日時間外_m As String Dim 時間外合計 As String Dim 前月時間外合計 As String Dim 前々月時間外合計 As String Dim 平均 As String Dim 問診票 As String Dim 削減書 As String Dim 担当者社員番号 As String Dim 担当者 As String Application.ScreenUpdating = False Sheets("個人用").Select 年月 = InputBox("ＯＴレポートの「年月」を入力してください 例：（前月）2012年9月 → 201209") Range("A2") = 年月 Sheets("健康診断問診票").Select 行 = 5 メール行 = 5 【こちらの繰返し処理が無限ループになっています。ご教示頂けないでしょうか】 Do Until Cells(行, 17).Value = "" If Cells(行, 17).Value <> 担当者社員番号 Then End If 出力処理: 社員番号 = Cells(行, 1).Value 社員名 = Cells(行, 2).Value 残業対象 = Cells(行, 3).Value 所属名コード = Cells(行, 4).Value 所属名 = Cells(行, 5).Value 事業所コード = Cells(行, 6).Value 事業所名 = Cells(行, 7).Value 社員区分 = Cells(行, 8).Value 平日時間外_m = Cells(行, 9).Value 休日時間外_m = Cells(行, 10).Value 時間外合計 = Cells(行, 11).Value 前月時間外合計 = Cells(行, 12).Value 前々月時間外合計 = Cells(行, 13).Value 平均 = Cells(行, 14).Value 問診票 = Cells(行, 15).Value 削減書 = Cells(行, 16).Value 担当者社員番号 = Cells(行, 17).Value 担当者 = Cells(行, 18).Value Sheets("個人用").Select Range("A5").Select Cells(メール行, 1).Value = 社員番号 Cells(メール行, 2).Value = 社員名 Cells(メール行, 3).Value = 残業対象 Cells(メール行, 4).Value = 所属名コード Cells(メール行, 5).Value = 所属名 Cells(メール行, 6).Value = 事業所コード Cells(メール行, 7).Value = 事業所名 Cells(メール行, 8).Value = 社員区分 Cells(メール行, 9).Value = 平日時間外_m Cells(メール行, 10).Value = 休日時間外_m Cells(メール行, 11).Value = 時間外合計 Cells(メール行, 12).Value = 前月時間外合計 Cells(メール行, 13).Value = 前々月時間外合計 Cells(メール行, 14).Value = 平均 Cells(メール行, 15).Value = 問診票 Cells(メール行, 16).Value = 削減書 Cells(メール行, 17).Value = 担当者社員番号 Cells(メール行, 18).Value = 担当者 '個別ファイル作成 Sheets("個人用").Select Sheets("個人用").Copy 年月 = Cells(2, "A") 担当者社員番号 = Cells(5, "Q") 担当者 = Cells(5, "R") Application.DisplayAlerts = False 'メッセージを出さない ActiveWorkbook.SaveAs Filename:="C:\担当者用\" & ("勤怠抽出" & 年月 & "(" & 担当者社員番号 & " " & 担当者 & "さん" & ")") & ".xls" ActiveWorkbook.Save ActiveWindow.Close Sheets("個人用").Select Rows("5:5").Select Range(Selection, Selection.End(xlDown)).Select Selection.ClearContents Sheets("健康診断問診票").Select 行の終わり: 行 = 行 + 1 Loop Sheets("ファイル作成").Select Range("A30").Select ActiveWorkbook.Save Application.ScreenUpdating = True MsgBox "ファイル作成が終了しました" End Sub
- ベストアンサー
- その他MS Office製品
- vba 日付時刻のセル エラー13型が一致しません
日付の入ったセルと時刻の入ったセルを合算させようとするとエラーが生じます。 エラー13「型が一致しません」と表示されます。 エラーが生じないようにするにはどうしたよいでしょうか？ Option Explicit Public num As Integer Sub newmacro() For num = 1 To Range("a1").End(xlDown).Row Cells(num, "F").Value = (Cells(num, "D").Value + Cells(num, "E").Value) - (Cells(num, "B").Value + Cells(num, "C").Value) Next num End Sub
- ベストアンサー
- Excel（エクセル）
- ExcelVBAで条件の追加
条件(0.5以下)に一致するセルの個数を数えます。 CH1 CH2 CH3 CH4 1 5 5 0.1 5 2 5 5 0.1 5 3 0.1 5 5 0.1 4 0.1 5 5 0.1 5 0.1 5 5 0.1 6 5 5 0.1 0.1 7 0.1 5 0.1 5 8 0.1 5 0.1 0.1 9 5 5 5 0.1 CH1の列の先頭行から数えていくと、0.5以下に一致するセルの個数はCH1では3個、2個となります。この3と2は足さずに別々に表示したいのです。 CH1が終わると、CH2→CH3→と繰り返します。 結果は以下のように列ごとに表にして示します。 CH1 CH2 CH3 CH4 3 2 4 2 3 2 今回は、以下の条件を追加したいのです。 「数えたセルの個数のうち、各列の先頭行や最終行を含むものは除く」 上の例でこの条件を追加しますと、CH3の2個、3個という結果のうち2個の方は先頭行を含んでいるので削除、CH4の結果のうち2個は最終行を含んでいるので削除、結果以下のようになります。 CH1 CH2 CH3 CH4 3 3 4 2 ＜コードの一部＞ Dim 出力値 As Variant Dim 出力先セル As Range Dim Counter As Long 'カウンタ Dim a As Long For a = 1 To 5 Set 出力先セル = Cells(2, 7＋a) For Each 出力値 In Range(Cells(32, a),Cells(60000, a)).Value If 出力値 <= 0.5 Then Counter = Counter + 1 ElseIf Counter <> 0 Then 出力先セル.Value = Counter '出力 Set 出力先セル = 出力先セル.Offset(1) Counter = 0 'リセット End If Next If Counter <> 0 Then 出力先セル.Value = Counter '出力 End If Next このif文の所に上記条件を追加したいのです。※先頭行(32行)と最終行(60000行)は固定
- ベストアンサー
- オフィス系ソフト
- エクセル2019 VBAについて
エクセル2019でVBAを使いコピーペーストの勉強中です、次の箇所(Dim i As integr)で、ユーザー定義型は定義されていませんと指摘されて止まってしまします、Sheet("データ")には3行のデータは入っています、VBA初心者のため、この後が、なかなか前に進めません、どうかよろしくおねがいします。 ********************************** Sub 練習() Dim s1 As Worksheet: Set s1 = Worksheets("請求書") Dim s2 As Worksheet: Set s2 = Worksheets("データ") Dim r1 As Integer: r1 = 18 Dim r2 As Integer: r2 = 2 { Dim i As integr } For i = 0 To 2 s1.Range(s1.Cells(r1 + i, 1), s1.Cells(r1 + i, 3)).Value = s2.Range(s2.Cells(r2 + i, 2), s2.Cells(r2 + i, 4)).Value s1.Cells(r1 + i, 4).Value = s1.sells(r1 + i, 2).Value * s1.Cells(r1 + i, 3).Value Next End Sub ***************************************
- ベストアンサー
- Excel（エクセル）
- excel マクロ 「select case」への条件盛り込み方法について
初めまして。 仕事にて、EXCELに工程遅延の原因を記入しているのですが、 同じ理由(約50種類あります)を何度も記入する必要があるため、 理由ごとに番号を割り振って、ボタン一つで記入できるようにしたいと思っています。 そこで、下記のようにマクロを作成してみたのですが、 現状では、例えばCells(1, 1)に何かを特記していた場合、 記入後にこのマクロを実行してしまうと、Cells(1, 1)の特記が、 上書きにより消えてしまいます。 そこで、Cells(num, 1)が空白であれば、Cells(num, 1)に上書きする、 という条件を付加したいのですが、可能でしょうか。 EXCELマクロの本を参考に作成しているのですが、 組み合わせの方法が分かりません。 お時間がある方いらっしゃいましたら、 ご検討よろしくお願い致します。 Sub 理由挿入() Dim num As Integer For num = 1 To 100 Select Case Cells(num, 2).Value Case 1 Cells(num, 1).Value = "理由１" Case 2 Cells(num, 1).Value = "理由２" Case 3 Cells(num, 1).Value = "理由３" Case 4 Cells(num, 1).Value = "理由４" End Select Next End Sub
- ベストアンサー
- オフィス系ソフト
- VBA アプリケーション定義またはオブジェクト定義エラーについて
doc_wbkというブックのSheets(2)の内容をdoc_wbk2のActiveSheetにコピーしようとしています。 以下のコードの5行目で「アプリケーション定義またはオブジェクト定義エラー」が出てしまいます。ブックやシートまで指定しないといけないのかと思い doc_wbk.Sheets(2) を5行目行頭に追加しましたが変わりません。逆に5行目行頭の . を外してやるとアクティブシートの内容をコピーしてしまいます。Sheets(2)の内容をコピーしてやるにはどうしたらよいでしょうか?よろしくお願いします。 Set doc_wbk = Workbooks.Open(doc_dir + doc_file, 0) With Sheets(2) If .Range("A4").Value <> "" Then row_num = .Range("a65536").End(xlUp).Row .Range(Cells(4, 1), Cells(row_num, 11)).Copy doc_wbk2.ActiveSheet.Cells(row_num2 + 1, 1) End If End With
- ベストアンサー
- Visual Basic
- VBAの得意な方、教えてください(初心者です)
エクセルのシートが セルA1に1 セルA2に2 セルA3に3 セルA4に4 セルA5に5 という数字が入っています。 で、セルD4には"=D2*5"という数式が入っています。 セルD2にA1の数値を代入して、出てきた数値をB1に入力、 次にD2にA2の数値を代入して、出てきた数値をB2に入力…以下続く というのをVBAで書いてみたら、下のような感じになりました。 Sub test() Dim d1 As Integer Dim d2 As Integer Dim d3 As Integer Dim d4 As Integer Dim d5 As Integer Dim p1 As Integer Dim p2 As Integer Dim p3 As Integer Dim p4 As Integer Dim p5 As Integer d1 = Cells(1, 1).Value Cells(2, 4).Value = d1 p1 = Cells(4, 4).Value Cells(1, 2).Value = p1 d2 = Cells(2, 1).Value Cells(2, 4).Value = d2 p2 = Cells(4, 4).Value Cells(2, 2).Value = p2 d3 = Cells(3, 1).Value Cells(2, 4).Value = d3 p3 = Cells(4, 4).Value Cells(3, 2).Value = p3 d4 = Cells(4, 1).Value Cells(2, 4).Value = d4 p4 = Cells(4, 4).Value Cells(4, 2).Value = p4 d5 = Cells(5, 1).Value Cells(2, 4).Value = d5 p5 = Cells(4, 4).Value Cells(5, 2).Value = p5 End Sub ここで質問です。 例では5個しかないのですが、実際は100行くらいのデータなんで 大変です。もっと簡単にする方法はありますか？ 実際のセルD4の数式は、他からも参照したりしているので、 ここはいじらずに教えてください。 Excel2000、Visual Basic 6.0 ってのを使っています。 よろしくお願いいたします。
- ベストアンサー
- オフィス系ソフト
- エクセルVBAで複数セルをコピーの制御構文
エクセルVBAで A8～I8のセルをコピーしてJ7～R7にコピーし、２行下に移り空白セルまで繰り返すという 処理をしたいと考えています Sub copy() Dim i As Integer i = 7 Do Until Cells(i, 1) = "" Cells(Cells(i,10),Cells(i,18).Value = Cells(Cells(i+1,1),Cells(i+1,9).Value i = i + 2 Loop End Sub と作ってみたところエラーで動きませんでした。 上記のプログラムはどこら辺がおかしいでしょうか？ よろしくお願いします。
- 締切済み
- Visual Basic
- 同一セル内での複数条件による抽出
セルの背景色で条件抽出をしております。 A1背景色＝赤→A3に「OK」書き出し、という具合です。 背景色がある場合の抽出はできるようになったのですが 同一セルで 「背景色なし」かつ「文字が記入されている」 ときに 他セルに「NG」などの文字が出るようにしたいのですが VBAで可能でしょうか？ 以下の部分まで（背景色がある場合）は出来たのですが。 御教授宜しくお願いいたします。 Dim 行番号 As Integer 行番号 = 7 Do Until Cells(行番号, 1).Value = "" If Cells(行番号, 9).Interior.ColorIndex = 5 Then Cells(行番号, 14).Value = "教えて" ElseIf Cells(行番号, 9).Interior.ColorIndex = 7 Then Cells(行番号, 14).Value = "GOO" End If 行番号 = 行番号 + 1 Loop
- ベストアンサー
- Visual Basic
- 終了日時から開始日時を引いた時間を求めるvba式
お世話になっています。 Excelで A列欄にタイトル B列欄に開始日 C列欄に開始時 D列欄に終了日 E列欄に終了時 のデータが有ります。 F列欄に合計を求めたいです。 今回は、 For～Next間のコードを教えて下さい 前回質問分 http://okwave.jp/qa/q9213232.html Option Explicit Public i As Long Public num As Integer Sub newmacro() Range("F1").Value = "合計" Columns("F").Select Selection.NumberFormatLocal = "[h]:mm" For num = 2 To Range("a1").End(xlDown).Row Cells("F", num).Value = Cells("D", num).Value + Cells("E", num).Value - Cells("B", num).Value + Cells("C", num).Value Next num End Sub よろしくお願い致します
- ベストアンサー
- Excel（エクセル）
お礼
申し訳ございません！！ 質問を締め切った際、お礼したつもりでいましたが、 今、改めて確認し、お礼がまだだった事に気が付きました。 改めて御礼申し上げます。 誠に失礼致しました。