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
お礼
これでいけました！！ どうもありがとうございます！！