Excel VBA質問箱 IV

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

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


7533 / 13644 ツリー ←次へ | 前へ→

【38464】セル内容のコピー 西本 06/6/3(土) 15:27 質問[未読]
【38469】Re:セル内容のコピー Kein 06/6/3(土) 16:28 回答[未読]
【38481】Re:セル内容のコピー 西本 06/6/3(土) 22:58 質問[未読]
【38483】Re:セル内容のコピー Kein 06/6/3(土) 23:30 回答[未読]
【38501】Re:セル内容のコピー 西本 06/6/5(月) 13:03 お礼[未読]

【38464】セル内容のコピー
質問  西本  - 06/6/3(土) 15:27 -

引用なし
パスワード
   はじめまして。

あるセルに値を代入したら、関連付けられた別のセルにも同様の値を入れたいと思っています。

例えば、セルA1に"AAAAA"と入力した時(入力はプルダウンによる)、セルA2〜A5までを"AAAAA"で自動で埋めるようにしたいです。
ここで、セルA2〜A5も独自に入力(プルダウンによる)できるようにしたいのですが、(A2〜A5による部分入力、A1による一括入力を実現したい)これが実現できずに困っています。

A2〜A5に IF(A1<>"",A$1,"") のようにすると、A2〜A5に入力した時、式が消えてしまいできませんでした。

このようなことは可能でしょうか。
よろしくおねがいします。

【38469】Re:セル内容のコピー
回答  Kein  - 06/6/3(土) 16:28 -

引用なし
パスワード
   A1の値が変わる度に、いちいちマクロによってA2:A5に入力規則を削除〜追加する、
というのは回りくどいので、まず初めに手作業で A1:A5 を選択して入力規則を
設定しておいて下さい。そしてそのシートのシートモジュールに

Private Sub Worksheet_Change(ByVal Target As Range)
  With Target
   If .Address <> "$A$1" Then Exit Sub
   If .Count > 1 Then Exit Sub
   If Not .Validation.Value Then Exit Sub
   Application.EnableEvents = False
   Range("A2:A5").Value = .Value
   Application.EnableEvents = True
  End With
End Sub

を入れて、A1 と A2:A5 でそれぞれ値を変更して、テストして下さい。

【38481】Re:セル内容のコピー
質問  西本  - 06/6/3(土) 22:58 -

引用なし
パスワード
   Kein 様 ありがとうございます。

教えていただいたとおりにすると実現できました。
しかし、複数のセルに同様のことをしようとして(セルA2〜A5にA1を反映、B2〜B5にB1を反映・・・・)これを応用しようとしたのですが(以下)、どうしてもできませんでした。

教えていただいたソースも理解できていないのですが、何が悪いのでしょうか。

Private Sub Worksheet_Change(ByVal Target As Range)
  With Target
   If .Address <> "$A$1" Then Exit Sub
   If .Count > 1 Then Exit Sub
   If Not .Validation.Value Then Exit Sub
   Application.EnableEvents = False
   Range("A2:A5").Value = .Value
   Application.EnableEvents = True
   
   If .Address <> "$B$1" Then Exit Sub
   If .Count > 1 Then Exit Sub
   If Not .Validation.Value Then Exit Sub
   Application.EnableEvents = False
   Range("B2:B5").Value = .Value
   Application.EnableEvents = True
   
   If .Address <> "$C$1" Then Exit Sub
   If .Count > 1 Then Exit Sub
   If Not .Validation.Value Then Exit Sub
   Application.EnableEvents = False
   Range("C2:C5").Value = .Value
   Application.EnableEvents = True
  End With
End Sub

【38483】Re:セル内容のコピー
回答  Kein  - 06/6/3(土) 23:30 -

引用なし
パスワード
   複数のセルを対象にするなら、先に回答したような単純なコードを
ずらずらと並べるだけではうまくいきません。ちょっと判定条件を
工夫する必要があります。こんな感じです。

Private Sub Worksheet_Change(ByVal Target As Range)
  If Intersect(Target, Range("A1:C1")) _
  Is Nothing Then Exit Sub
  With Target
   If .Count > 1 Then Exit Sub
   If Not .Validation.Value Then Exit Sub
   Application.EnableEvents = False
   .Offset(1).Resize(4).Value = .Value
   Application.EnableEvents = True
  End With  
End Sub

【38501】Re:セル内容のコピー
お礼  西本  - 06/6/5(月) 13:03 -

引用なし
パスワード
   Kein 様
ありがとうございました。

以下のように、Kein様のソースを応用させて頂くことにより、
様々なパターンに応用することができました。

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim ofs As Integer
  Dim res As Integer
  Dim flg As Integer
  
  flg = 0
  If Intersect(Target, Range("C5:E5")) Is Nothing Then
  Else
    ofs = 2
    res = 12
    flg = 1
  End If
  If Intersect(Target, Range("C6:E6")) Is Nothing Then
  Else
    ofs = 13
    res = 7
    flg = 1
  End If
  If Intersect(Target, Range("C26:E26")) Is Nothing Then
  Else
    ofs = 1
    res = 6
    flg = 1
  End If
  If flg = 0 Then
    Exit Sub
  End If

  With Target
    If .Count > 1 Then Exit Sub
    If Not .Validation.Value Then Exit Sub
    Application.EnableEvents = False
    .Offset(ofs).Resize(res).Value = .Value
    Application.EnableEvents = True
  End With
End Sub

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