Excel VBA質問箱 IV

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

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


43715 / 76732 ←次へ | 前へ→

【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 
1 hits

【38041】keinさん コジマ 06/5/25(木) 13:50 質問
【38046】Re:keinさん Kein 06/5/25(木) 14:32 回答
【38055】Re:keinさん コジマ 06/5/25(木) 15:25 質問
【38056】Re:keinさん Kein 06/5/25(木) 15:30 発言
【38058】Re:keinさん コジマ 06/5/25(木) 15:40 お礼

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