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

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

新規登録して質問してみよう
ただいま回答率
85.50%
VB

VB(ビジュアルベーシック)はマイクロソフトによってつくられたオブジェクト指向プログラミング言語のひとつで、同社のQuickBASICが拡張されたものです。VB6の進化版といわれています。

VBA

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

マクロ

定義された処理手続きに応じて、どのような一連の処理を行うのかを特定させるルールをマクロと呼びます。

Q&A

解決済

2回答

6853閲覧

VBA・マクロ 行数の追加について

khr0404

総合スコア43

VB

VB(ビジュアルベーシック)はマイクロソフトによってつくられたオブジェクト指向プログラミング言語のひとつで、同社のQuickBASICが拡張されたものです。VB6の進化版といわれています。

VBA

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

マクロ

定義された処理手続きに応じて、どのような一連の処理を行うのかを特定させるルールをマクロと呼びます。

0グッド

0クリップ

投稿2017/06/02 00:41

編集2017/06/02 04:01

###前提・実現したいこと
閲覧いただきありがとうございます。
現在エクセルでマクロを作成しているのですが、
N列に特定の数字(1,4,6,38など)が羅列されており、その数字を読み込みその下にN列の数字-1行を追加するというマクロをくんでいるのですが、
160行くらいあるなかの100行を超えたあたりから行数が追加されなくなる場合があるといった症状となっています。

原因はマクロはあまりIf-Elseを多用すると上手く動かないことがあるとの記事をみたことがあるのですがそれかと思っているのですが、Select文のほうがパフォーマンスが良いでしょうか?

ソースからこれはいけないといったご指摘があったらアドバイスを頂きたいです。

宜しくお願い致します。

###該当のVBA

Sub InsertRow() Dim i As Integer Dim intStart As Integer Dim intCol As Integer Dim strSheetName As Worksheet Set strSheetName = ActiveSheet intStart = 2 '開始する行数 intCol = 14 '数字を読み込む列 i = intStart '追加する行数の先頭位置 Dim j As Integer '追加する行数の中に既に空白行があったらその行数分 msg_1 = "N列に指定されている員数-1行を追加しますか" If MsgBox(msg_1, vbYesNo) = vbNo Then Exit Sub '行を追加してよいかのポップアップを出す Application.ScreenUpdating = False '処理終了まで画面表示はそのまま Do While i < 10000 '読み込む行 If Cells(i, intCol).Value = "" Then 'セルに何も記入されていない時は次の行を読み込む 'Exit Do i = i + 1 Else If Cells(i, intCol).Value = 0 Then 'セルに0が記入されているときは次の行を読み込む i = i + 1 Else If Cells(i, intCol).Value = 1 Then 'セルの値が1の時は行数を追加する必要がない i = i + 1 Else Dim cbl As Range '空白行数を調べる際の範囲を指定 Set cbl = Range(Cells(i + 1, intCol), Cells(i + Cells(i, intCol).Value, intCol)) '空白行を調べる際の範囲 j = WorksheetFunction.CountBlank(cbl) '空白行の行数分 Range(Rows(i + 1), Rows(i + Cells(i, intCol).Value - 1 - j)).Select 'i=選択されている行の次の行から指定されたN列の追加行数を選択した状態 'jを引くことにより空白行数を含めたN列の値となる Selection.Insert '選択された行数分追加 i = i + Cells(i, intCol).Value '次の指定するN列 End If End If End If Loop Application.ScreenUpdating = True End Sub

###補足情報(言語/FW/ツール等のバージョンなど)
Office2013

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

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

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

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

guest

回答2

0

原因はマクロはあまりIf-Elseを多用すると上手く動かないことがあるとの記事をみたことがあるのですがそれかと思っているのですが、Select文のほうがパフォーマンスが良いでしょうか?

そのような話は聞いたことがないし、3階層ぐらいのネストで上手く動かないような言語が現在まで生き残れはずはないですね。

「100行を超えたあたりから」というのはちょっと分かりませんが、
とりあえず気になるのは、

Do While i < 10000 '読み込む行

と処理する行数を固定にしているところですね。
行を挿入していくので、処理対象の行はどんどん後ろに追いやらていきます。
固定の行数を超えたら、処理されないです。

このように挿入する場合は、最後の行から前に移動しながら挿入していくとこのようなことがないし、
シンプルに記述できます。

コード例

For i = Cells(Rows.Count, intCol).End(xlUp).Row To 2 Step -1 '挿入処理 Next i

Cells(Rows.Count, intCol).End(xlUp).Row でデータのある最終行が取得できます。

追記

細かい仕様は不明ですが、やりたいことは下記のようなことかな。

N列にある数値分の空白行のその行の下に挿入する。
ただし、空白行がすでにある場合は、それを含めて指定の行数になるように挿入する。

Sub InsertRow1() Dim i As Long Dim intStart As Long Dim intCol As Long Dim cntBlank As Long Dim AddCnt As Long Dim msg_1 As String intStart = 2 '開始する行数 intCol = 14 '数字を読み込む列 i = intStart '追加する行数の先頭位置 Dim j As Integer '追加する行数の中に既に空白行があったらその行数分 msg_1 = "N列に指定されている員数-1行を追加しますか" If MsgBox(msg_1, vbYesNo) = vbNo Then Exit Sub '行を追加してよいかのポップアップを出す Application.ScreenUpdating = False '処理終了まで画面表示はそのまま '最終行の1行上から上へ読み込む For i = Cells(Rows.Count, intCol).End(xlUp).Row - 1 To intStart Step -1 Select Case Cells(i, intCol).Value Case "" cntBlank = cntBlank + 1 '空白行カウント Case Is >= 2 AddCnt = Cells(i, intCol).Value - cntBlank - 1 '追加する行数計算 If AddCnt > 0 Then Range(Rows(i + 1), Rows(i + AddCnt)).Select Selection.Insert '選択された行数分追加 End If cntBlank = 0 Case Else cntBlank = 0 End Select Next i Application.ScreenUpdating = True End Sub

実行結果
イメージ説明

ロジック
最終行の1行上から順に前に移動して読み込む(最終行は空白行挿入する必要はない)

上へ移動するときに、
空白行をカウントしていく
2以上の数値がでたら、そこからカウントした空白行を引いた行数分挿入する、その後空白行カウントを0に初期化する
それ以外は、空白行カウントを0に初期化する

投稿2017/06/02 02:02

編集2017/06/02 06:01
hatena19

総合スコア33620

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

khr0404

2017/06/12 07:38

>hatena19様 ご回答ありがとうございます。 下から処理する方法をとりたかったのですが、今回質問させていただいた内容のほかに上から処理をしていき、指定された回数ループをとらなければならなく下からの処理ができなく苦戦していました・・・ わかりやすい説明、コードのご掲示ありがとうございました。 後ほど最終的にまとめたコードを載せます。 ご返信が遅れてしまい大ましたが、ご回答ありがとうございました。
guest

0

ベストアンサー

原因

If文のネストが無暗に深いのも確かに気になりますが、今回の現象はロジックの問題です。

対象行の次行から追加したい行数分の範囲を選択し、空行の数を差し引いていますが、この空行の数え方が問題だと思います。
例えば

N ===== 1: 2: 5 3: 4: 5

のようなデータがあった場合、まず2行目から4行目の間が4行の空行になるよう3行追加したいのだと思いますが、実際にはN3~N7の範囲の空行の数を数え、4行見つかるためその分追加行数から差し引かれてしまいます。
(結果、意図しない範囲に行挿入を行う異常動作となります)

対応

追加範囲の空行数を調べる方法では、実際には不要な空行まで数えてしまいました。
なので、この部分を「追加する行位置に既に連続する空行があれば、その行数分減らして行追加する」ように変更しては同でしょうか?

以下のサンプルでは、現在行の次行から、最初に値の入っているセルをFind関数で探すことで空行の数を計算するようにしました。

Sub InsertRowX() Dim i As Integer Dim intStart As Integer Dim intCol As Integer Dim strSheetName As Worksheet Set strSheetName = ActiveSheet ' strSheetName = ActiveSheet ' "クレーム2_16年度ARC組合せセットコード体系表_1" intStart = 2 '開始する行数 intCol = 14 '数字を読み込む列 i = intStart '追加する行数の先頭位置 Dim j As Integer '追加する行数の中に既に空白行があったらその行数分 msg_1 = "N列に指定されている員数-1行を追加しますか" If MsgBox(msg_1, vbYesNo) = vbNo Then Exit Sub '行を追加してよいかのポップアップを出す Application.ScreenUpdating = False '処理終了まで画面表示はそのまま Do While i < 10000 '読み込む行 Dim AddCnt As Double AddCnt = Val(Cells(i, intCol).Value) '追加行数を取得 If AddCnt <= 1 Then 'セルに何も記入されていない、もしくは追加行数が1以下の場合はスキップ i = i + 1 Else Dim cbl As Range '空白行数を調べる際の範囲を指定 Set cbl = Range("N:N").Find(What:="*", after:=Cells(i, "N")) '次行以降で空白でない最初のセルを検索 If cbl Is Nothing Then '見つからなければ最終行 j = 0 Else '見つかった場合、空行数を計算 j = cbl.Row - i - 1 End If Range(Rows(i + 1), Rows(i + AddCnt - 1 - j)).Select 'i=選択されている行の次の行から指定されたN列の追加行数を選択した状態 'jを引くことにより空白行数を含めたN列の値となる Selection.Insert '選択された行数分追加 i = i + AddCnt '次の指定するN列 End If Loop Application.ScreenUpdating = True End Sub

デバッグ実行すれば思った行数が取得できていないことに気が付けると思いますので、思うように動かないときはデバッグしてみることをお勧めします。

投稿2017/06/02 02:50

jawa

総合スコア3013

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

khr0404

2017/06/12 07:34

>jawa様 ご回答ありがとうございます。 なるほど・・・ 数え方が影響していたのですね。 コードのご掲示もありがとうございました。 このコードにとんだ先が空白行だった時の処理を追加して対処しました! ご返信が遅れましたが回答ありがとうございました!
guest

あなたの回答

tips

太字

斜体

打ち消し線

見出し

引用テキストの挿入

コードの挿入

リンクの挿入

リストの挿入

番号リストの挿入

表の挿入

水平線の挿入

プレビュー

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

ただいまの回答率
85.50%

質問をまとめることで
思考を整理して素早く解決

テンプレート機能で
簡単に質問をまとめる

質問する

関連した質問