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

回答No.2

tsubuyuki · ベストアンサー

Ｑ列に式が入っていても、その式の返り値が空白("")ならDo～Loopから抜けて
処理は止まりますので、そこは問題ないかと。
コードを拝見させていただきましたが、見た感じ「無限ループ」の理由は無いように思います。

ただ一つ、私が気になったのは、Do～Loopの中の
> If Cells(行, 17).Value <> 担当者社員番号 Then
>
> End If
このIfの部分なのですが、この中では何か処理をされているのでしょうか？
処理が無いなら、このIfは全く意味が無いですよね。
処理があるなら、この中にループの原因があるかもしれません。
変数「担当社員番号」はマクロ起動時には空白（""）ですから、
繰り返し（Do）の処理一回目でIf内に入りますから。

ここに原因があるのであれば、現状でこちらでは検証が不可能です。
ＶＢＥ画面で当該コード内にカーソルを置き、
Ｆ８キーでステップインモードでコードを確認しながら動かせますので
（※Ｆ８キーを押すと、次の行の処理に移ります。）
とりあえず、これで「無限ループする行（処理）＝理由」を自力で特定してみましょう。
原因がわかれば、良い対処法が出てくるかもしれません。

余計なお節介ですが、

> 社員番号 = Cells(行, 1).Value
> 　　　（中略）
> 担当者 = Cells(行, 18).Value
>
> Sheets("個人用").Select
> Range("A5").Select
>
> Cells(メール行, 1).Value = 社員番号
> 　　　（中略）
> Cells(メール行, 18).Value = 担当者

ここは
　　Sheets("健康診断問診票").Range(Cells(行, 1), Cells(行, 18)).Copy
　　Sheets("個人用").Range(Cells(行, 1), Cells(行, 18)).PasteSpecial Paste:=xlPasteValues
　　Sheets("個人用").Select
Range("A5").Select
これでいわゆる「値の貼り付け」が可能です。
変数も少なく出来ますし、コードも短く済みます。
ちょっとスッキリすると思いますが・・まぁ、この辺は好みですけどね。

お礼

大変お礼が遅くなり申し訳ございません。
詳しいご説明とアドバイスを頂きまして有難うございました。
やっと作業ができそうなのでマクロを改良してみます。

補足

ご回答頂きまして有難うございます。
無限ループは空のデータセルをクリアしたところ解消されました。
If Cells(行, 17).Value <> 担当者社員番号 Thenにつきましては、
リスト内に各担当者の複数データを１ファイルにまとめてファイル保存を繰り返す（１行下セルの担当者が変更したら別ファイル）ということで入力をしました。
まったく異なるコードで申し訳ございません。

ご教示頂きました、
>Sheets("個人用").Range(Cells(行, 1), Cells(行, 18)).PasteSpecial Paste:=xlPasteValues
をＦ８キーで実行したところ、
「'1004'アプリケーション定義またはオブジェクトの定義エラーです」とエラー表示がされました。
大変お手数をお掛けいたしますがご教示頂けないでしょうか。
詳しいExcelの内容は、No.1kyboさんの補足に記載いたしましたのでご参照頂ければと思います。
よろしくお願い致します。

回答No.1

kybo

コード自体に特に問題となる部分はないと思います。
おそらく、表のほうの問題ではないかと思われます。

Do Until Cells(行, 17).Value = ""

は、空欄のセルになるまで続けます。Q列に実は数式等入っていて、値は空欄ではないセルがかなり長く続いているのではないかと思います。

Q列のデータを新規シートなどに値で貼り付けし、どこまでデータがあるか見たほうがいいです。

お礼

お礼が大変遅くなり申し訳ございませんでした。
ご回答頂きまして有難うございます。
質問と異なる質問をしてしまい申し訳ございませんでした。

補足

言葉足らずで申し訳ございません。
Do Until Cells(行, 17).Value = ""でファイルを作成することはできるのですが、
各担当者にデータをまとめて１ブックに保存し、次の担当者へ進むというイメージでマクロを作成しています。
イメージと現状は以下になります。

1行目
2行目
3行目 A列 Ｂ列 省略 Q列 R列
4行目 社員番号 社員名 省略 担当者ＩＤ　担当者
5行目 　111 　山田 　　200 　　山本
6行目 　112 　鈴木 　　200 　　山本
7行目 　113 　田中 　　200 　　山本
8行目 　114 　佐藤 　　201 　　安藤
9行目 　115 　山口 　　201 　　安藤

↓ マクロの処理をすると・・・

1行目
2行目
3行目 A列 Ｂ列 省略 Q列 R列
4行目 社員番号 社員名 省略 担当者ＩＤ　担当者
5行目 　　111 　　山田 　　200 　　山本
6行目 　　112 　　鈴木 　　200 　　山本
7行目 　　113 　　田中 　　200 　　山本

5・6・7行目を勤怠抽出2012年11月（200 山本さん）.xlsで作成

1行目
2行目
3行目 A列 Ｂ列 省略 Q列 R列
4行目 社員番号 社員名 省略 担当者ＩＤ　担当者
5行目 　　114　　佐藤 　　201 　　安藤
6行目 　　115 　山口 　　201 　　安藤

5・6行目を勤怠抽出2012年11月（20１ 安藤さん）.xlsで作成

【現状】

1行目
2行目
3行目 A列 Ｂ列 省略 Q列 R列
4行目 社員番号 社員名 省略 担当者ＩＤ　担当者
5行目 　114 　佐藤 　　201 　　安藤
6行目 　115 　山口 　　201 　　安藤

5行目を勤怠抽出2012年11月（20１ 安藤さん）.xlsで作成
※6行目を上書きで勤怠抽出2012年11月（20１ 安藤さん）.xlsを作成
Q列に空欄が現れても、Q5に戻って繰り返しファイルを作成し続けます。