Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

43719 / 76736

←次へ　｜　前へ→


	【38046】Re:keinさん

Kein - 06/5/25(木) 14:32 -


	引用なし

	パスワード

あぁ・・そーいうことですか、分かりました。
ならば項目数が 4 であることを前提に、以下のマクロを各モジュールに入れ、
いったんブックを保存して閉じ、再度開いてから2006年度シートにデータを
入力してみて下さい。A:D列に間違いなく4つのデータを入れたとき、その月の
シートへ自動的に転記します。また、その際にコピー先で重複した値があれば、
メッセージを出してから入力したところをクリアして終わります。

[標準モジュール]

Sub Auto_Open()
　 Dim i As Integer

　 For i = 1 To 12
　　　With Sheets(i & "月")
　　　　 If Not IsEmpty(.Range("A2").Value) Then
　　　　　　.Range("AA:AA").ClearContents
　　　　　　.Range("A2", .Range("A65536").End(xlUp)) _
　　　　　　.Offset(, 26).Formula = "=CONCATENATE($A2,$B2,$C2,$D2)"
　　　　 End If
　　　End With
　 Next i
End Sub

[2006年度シートのシートモジュール]

Private Sub Worksheet_Change(ByVal Target As Range)
　 Dim MyR As Range
　 Dim Sn As String, CkSt As String
　 Dim MyV As Variant

　 With Target
　　　If .Column <> 4 Then Exit Sub
　　　If .Row = 1 Then Exit Sub
　　　If IsEmpty(.Value) Then Exit Sub
　　　With .Offset(, -3)
　　　　 If Not IsDate(.Value) Then Exit Sub
　　　　 Sn = Month(.Value) & "月"
　　　　 Set MyR = .Resize(, 4)
　　　End With
　 End With
　 With Application
　　　If .CountA(MyR) < 4 Then
　　　　 MsgBox "A" & .Row & ":D" & .Row & _
　　　　 "　に未入力のセルがあります", 48
　　　　 Set MyR = Nothing: Exit Sub
　　　End If
　　　MyV = .Transpose(.Transpose(MyR.Value))
　　　CkSt = Join(MyV, "")
　　　If Not IsError(.Match(CkSt, Sheets(Sn).Range("AA:AA"), 0)) Then
　　　　 MsgBox "そのデータは既にコピー済みです", 48
　　　　 .EnableEvents = False
　　　　 MyR.ClearContents
　　　　 .EnableEvents = True
　　　Else
　　　　 MyR.Copy Sheets(Sn).Range("A65536").End(xlUp).Offset(1)
　　　End If
　 End With
　 Set MyR = nothing
End Sub　

0 hits

▼

【38041】keinさん コジマ 06/5/25(木) 13:50