Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


6918 / 76732 ←次へ | 前へ→

【75410】Re:[無題]
発言  マナ  - 14/3/21(金) 13:38 -

引用なし
パスワード
   できるだけ元のコードを残してありますが
順番はあちこち入れ替えました。
データがないので動作確認はしていません。

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
3 hits

【75405】[無題] りんご 14/3/21(金) 0:03 質問
【75410】Re:[無題] マナ 14/3/21(金) 13:38 発言
【75416】Re:[無題] りんご 14/3/22(土) 8:54 お礼
【75442】Re:[無題] マナ 14/3/27(木) 21:02 発言
【75443】Re:[データがないときの処理] りんご 14/3/28(金) 13:05 質問
【75444】Re:[データがないときの処理] マナ 14/3/28(金) 19:21 発言

6918 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free