| |
できるだけ元のコードを残してありますが
順番はあちこち入れ替えました。
データがないので動作確認はしていません。
Option Explicit
Sub まとめて登録()
Dim 登録 As Worksheet, 当月 As Worksheet
Dim 月 As Long, 日 As Long
Dim 縦 As Long, 最終行 As Long
Dim msg As Long
Dim 行 As Long
Set 登録 = Worksheets("登録")
月 = 登録.Cells(4, 18).Value
日 = 登録.Cells(4, 20).Value
msg = MsgBox("入力内容を登録月" & 月 & "シートに転送します。" & vbCrLf & "よろしいですか？", vbOKCancel + vbExclamation, "入力内容の転送")
If msg <> vbOK Then MsgBox "操作を中断しました": Exit Sub
Set 当月 = Worksheets("登録月" & 月)
縦 = 7
Do Until 当月.Cells(縦, 20).Value = ""
縦 = 縦 + 1
Loop
If WorksheetFunction.CountIf(当月.Range(当月.Cells(7, 20), 当月.Cells(縦, 20)), 日) >= 1 Then
msg = MsgBox("この日付データはすでに登録されています ", vbOKOnly + vbExclamation)
If msg <> vbOK Then Exit Sub
End If
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
'最終行を取得（Q23から上方向に牽索）
最終行 = 登録.Cells(23, 17).End(xlUp).Row
For 行 = 7 To 最終行
当月.Cells(縦, 20).Value = 日
当月.Cells(縦, 21).Resize(, 7).Value = 登録.Cells(行, 17).Resize(, 7).Value
縦 = 縦 + 1
Next
With 当月
.Range(.Cells(7, 20), .Cells(縦 - 1, 27)).Sort _
Key1:=.Cells(7, 20), _
Order1:=xlAscending, _
Header:=xlNo, _
Orientation:=xlTopToBottom
End With
With 登録
.Range(.Cells(5, 4), .Cells(10, 7)).ClearContents
.Range(.Cells(12, 4), .Cells(15, 7)).ClearContents
.Range(.Cells(17, 4), .Cells(24, 7)).ClearContents
.Range(.Cells(26, 4), .Cells(29, 7)).ClearContents
.Range(.Cells(5, 11), .Cells(12, 14)).ClearContents
.Range(.Cells(14, 11), .Cells(19, 14)).ClearContents
.Range(.Cells(21, 11), .Cells(26, 14)).ClearContents
.Range(.Cells(7, 18), .Cells(23, 18)).ClearContents
End With
MsgBox "データ転送が終了しました。", vbOKOnly + vbInformation, "終了"
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.Calculate
Application.ScreenUpdating = True
End Sub
|
|
マナ
- 14/3/21(金) 13:38 -
