Excel VBA質問箱 IV

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

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

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
1253 / 13644 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【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 発言[未読]
【75405】［無題］
質問  りんご E-MAIL  - 14/3/21(金) 0:03 -
引用なし
パスワード
   次のように登録のマクロを組みました。1.登録日と同じデータが当月シートにある場合警告メッセージ、2.当月シートにデータ張付が完了したら日付順に整列させるようにしたいのですが、うまくいきません。構文の不具合もあると思いますが、なかなか解決できません。詳しい方のご指導をお願いいたします。


Sub まとめて登録()

Application.ScreenUpdating = False
　　Application.Calculation = xlCalculationManual
　　Application.DisplayAlerts = False
Set 登録 = Worksheets("登録")
　　　月 = 登録.Cells(4, 18)
　　　日 = 登録.Cells(4, 20)
　　　区分 = 登録.Cells(7, 17)
　　　人数 = 登録.Cells(7, 18)
　　　あ = 登録.Cells(7, 19)
　　　い = 登録.Cells(7, 20)
　　　う = 登録.Cells(7, 21)
　　　え = 登録.Cells(7, 22)
　　　備考 = 登録.Cells(7, 23)

　'最終行を取得（Q23から上方向に牽索）

　最終行 = 登録.Range("Q23").End(xlUp).Row


Set 当月 = Worksheets("登録月" & 月)
　　　縦 = 7
　　 msg = MsgBox("入力内容を登録月" & 月 & "シートに転送します。" & vbCrLf & "よろしいですか？", vbOKCancel + vbExclamation, "入力内容の転送")
　　 If msg = vbOK Then
　　
　　
　If Worksheet.CountIf("当月.Range(当月.cells(7,20).vaiue:当月.cells(400,20).value", 登録.Cells(4, 20).valuw) ＜１ Then
　　　　　
　 msg = MsgBox("この日付データはすでに登録されています " vbOKonly + vbExclamation)
　　
　If msg = vbOK Then

　For 行 = 7 To 最終行
　　

　Do Until 当月.Cells(縦, 20) = ""
　　　縦 = 縦 + 1
　Loop
　　　
　　　当月.Cells(縦, 20) = 日
　　　当月.Cells(縦, 21) = 区分
　　　当月.Cells(縦, 22) = 人数
　　　当月.Cells(縦, 23) = あ
　　　当月.Cells(縦, 24) = い
　　　当月.Cells(縦, 25) = う
　　　当月.Cells(縦, 26) = え
　　　当月.Cells(縦, 27) = 備考
　　　
　　　
　　　For 横 = 17 To 23
　　　　当月.Cells(縦, 横 + 4) = Cells(行, 横)
　　　Next
　　　　
　　
　Next
　　
　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, "終了"

　Else: MsgBox "操作を中断しました"
　
　　Exit Sub

　
End If
　　Application.DisplayAlerts = True
　　Application.Calculation = xlCalculationAutomatic
　　Application.Calculate
　　Application.ScreenUpdating = True


End Sub
【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
【75416】Re:［無題］
お礼  りんご  - 14/3/22(土) 8:54 -
引用なし
パスワード
   早速の回答ありがとうございました。一部訂正　＜＞を＝　にしてＯＫでした。
【75442】Re:［無題］
発言  マナ  - 14/3/27(木) 21:02 -
引用なし
パスワード
   ▼りんご さん：
>>追加の質問ですが、以前にご指導いただいたマクロですが、入力項目（R7:Ｖ23）に値がないときに処理を中断するつもりで、式を張付ましたがうまくいきません。　このやり方は何が問題なのでしょうか？
>理解できていないのでよろしくお願いします。
>
>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
>　　
>　　　 If WorksheetFunction.CountBlank(Range("R7:Ｖ23")) > 0 Then
>　　　　　MsgBox "登録データがありません"
>　　　　　Exit Sub
>　　　 End If
>
>　　
>　　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 + vbCritical)
>　　　　If msg = vbOK Then Exit Sub
>　　
>　　End If
>　　　　　　(以下　略）


そちらのデータ配置がどんなものか、コードから推測しているだけなので
どう修正したらよいかも推測にばりますが、

If 登録.Cells(7,18).Value="" Then
とか
If 登録.Cells(7,17).Value="" Then
では、だめなのでしょうか？
【75443】Re:［データがないときの処理］
質問  りんご  - 14/3/28(金) 13:05 -
引用なし
パスワード
   ありがとうございます。再質問になります。


作業範囲内登録シート（Ｒ７：Ｖ２３）にデータがなにもないときに、作業を実行しないようにしたいのです。作業範囲内セルに入力セル数がないとき　　

　　If WorksheetFunction.Couna(Range("r7:v23")) > 0 Then

としてもみましたが、うまくゆきません

　次ような式となっております。診断よろしくお願いします。

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
　　
　 '最終行を取得（Q23から上方向に牽索）
　　最終行 = 登録.Cells(23, 17).End(xlUp).Row
　　
　　
　　'If 登録.Range(登録.Cells(7, 18), 登録.Cells(最終行, 22)).Value = "" Then


　　　　MsgBox "入力データがありません"
　　　　　
　　　　　Exit Sub
　　　 End If

　　
　　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 + vbCritical)
　　　　If msg = vbOK Then Exit Sub
　　
　　End If
　　
　　Application.ScreenUpdating = False
　　Application.Calculation = xlCalculationManual
　　Application.DisplayAlerts = False


　　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
　　　
　　　 .Range(.Cells(7, 18), .Cells(23, 23)).ClearContents
　　　
　　　
　　End With
　　MsgBox "データ転送が終了しました。", vbOKOnly + vbInformation, "終了"
　　Application.DisplayAlerts = True
　　Application.Calculation = xlCalculationAutomatic
　　Application.Calculate
　　Application.ScreenUpdating = True
End Sub
【75444】Re:［データがないときの処理］
発言  マナ  - 14/3/28(金) 19:21 -
引用なし
パスワード
   データは７行目から順番に入力されるのではないのですか。
Q7あるいは、R7にデータがない場合でも、
７行目以下にデータがあることもありますか。

＞最終行 = 登録.Cells(23, 17).End(xlUp).Row

は、データがある一番下の行という意味ではないのですか。

やっぱり、よくわかりませんが、こうですか？
If WorksheetFunction.COUNTBLANK(登録.Range("R7:V23")) > 0 Then
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
1253 / 13644 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free