excel|シートのリンク方法について

質問

いつもお世話になります。

エクセルは2010を利用しています。

現在、下記のコードで、文字揃えを制御しています。
A1～C1は、それぞれセルが結合されています。

----------------------------------------------------------
Sub HorizontalAndVerticalAlignmentSamp1()

If Range("B1").Value = "" Then

With Range("C1")
.HorizontalAlignment = xlHAlignRight

End With
Else

With Range("C1")
.HorizontalAlignment = xlHAlignLeft
End With
End If

If Range("A1").Value = "" Then

With Range("B1")
.HorizontalAlignment = xlHAlignRight
End With
Else

With Range("B1")
.HorizontalAlignment = xlHAlignCenter
End With

End If

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Range("A1:C1") <> "" Then Call HorizontalAndVerticalAlignmentSamp1
End Sub
-------------------------------------------------------------------------

シート２、シート３は、A1～C1のセルがシート1とおなじように結合されています。

シート1で、A1～C1に文字を入力したら、おなじ文字と文字揃えがシート2、シート3でも反映、シート１で、A1～C1に入力されていた文字を削除すると、シート2、シート3も消えているようにしたいです。

わたしの知っている限りの範囲でがんばってみたことは
シート２、シート３のA1に「=Sheet1!A1」、B1に「=Sheet1!B1」、C1に「=Sheet1!C1」と入力して
シート２、シート３にも上記とおなじマクロを記述してみました。

けれど、シート１で入力しても、シート２、シート３を選択して、どこかのセルを1回選択しないと、文字揃えが反映されませんでした。

そこで、
シート１の上記マクロに
Sheet2.select
Sheet3.select
Sheet1.select
を追加してみました。

けれど、あたりまえといえばあたりまえなのですが、シート１でどこかのセルを選択するごとにシート２、シート３、シート１と画面が切り替わるようになり、画面が切り替わったあとにシート２、シート３を見てみても、文字揃えはどこかのセルを選択しないかぎりおなじく反映されませんでした。

どのようにしたらいいのかが分からず、質問いたしました。
みなさまのお知恵を借していただけますと幸いです。
どうかよろしくお願いいたします。

回答No.7

cj_mover · ベストアンサー

＃２-６、ｃｊです。＃６補足欄へのレスです。

編集が難しいということのようですし、
元々１行めしか想定して書いていませんでしたから、
その点を考慮に入れて、設計変えました。
この際、統一します。

セル範囲がどのように変更になろうとも、
３つの（結合）セルという前提が崩れない限り、
指定箇所　にある、セル参照文字列、だけを修正すれば、
対応できるように書き直しました。

' ' 〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓

' ' 以下、Sheet1モジュール　' cj8271875_5

Private Sub Worksheet_Change(ByVal Target As Range)
　　Const fSRef = "D13,G13,I13"　　'　指定箇所　３つの結合セルの左上セルの番地をそれぞれカンマ区切りで
'　　Const fSRef = "A1,D1,F1"　　'　No.5 での追加オーダー　の場合
'　　Const fSRef = "A1,B1,C1"　　'　原質問　の場合
　　Dim arrRef() As String
　　Dim wsh As Worksheet
　　Dim HAlignB As Excel.XlHAlign
　　Dim HAlignC As Excel.XlHAlign

　　If Intersect(Range(fSRef), Target(1)) Is Nothing Then Exit Sub

　　arrRef() = Split(fSRef, ",")

　　Application.EnableEvents = False
　　On Error GoTo ErrHndl_
　　For Each wsh In Sheets(Array("Sheet2", "Sheet3"))
　　　　wsh.Cells(Target.Row, Target.Column).Value = Target(1).Value
　　Next
　　On Error GoTo 0
　　Application.EnableEvents = True

　　If Range(arrRef(1)).Value = 0 Then
　　　　HAlignC = xlHAlignRight
　　Else
　　　　HAlignC = xlHAlignLeft
　　End If
　　If Range(arrRef(0)).Value = 0 Then
　　　　HAlignB = xlHAlignRight
　　Else
　　　　HAlignB = xlHAlignCenter
　　End If
　　For Each wsh In Sheets(Array("Sheet1", "Sheet2", "Sheet3"))
　　　　wsh.Range(arrRef(1)).HorizontalAlignment = HAlignB
　　　　wsh.Range(arrRef(2)).HorizontalAlignment = HAlignC
　　Next

　　Exit Sub
ErrHndl_:
　　MsgBox "シート：　Sheet1" & vbLf & "セル範囲：" & Target(1).Address(0, 0) _
　　　　& vbLf & vbTab & ".Valueプロパティの取得" & vbLf & "　　または" _
　　　　& vbLf & "シート：　" & wsh.Name & vbLf & "セル範囲：" & Target(1).Address(0, 0) _
　　　　& vbLf & vbTab & ".Valueプロパティの設定" & vbLf & "　　に失敗しました。" _
　　　　& vbLf & vbLf & "実行時エラー'" & Err & vbLf & Err.Description, vbExclamation
　　Resume Next
End Sub

' ' 〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓

お礼

cj_moverさまへ
これまでいろいろと親身に教えてくださいまして、ほんとうにありがとうございました。
cj_moverさんが教えてくださいましたコードを元に、下記のように少し修正を加えまして、無事うまくいきました。

--------------------------------------------------------------------------------------------------------

Private Sub Worksheet_Change(ByVal Target As Range)
Const fSRef = ("D13,G13,I13") '　指定箇所　３つの結合セルの左上セルの番地をそれぞれカンマ区切りで
Const fSRef1 = ("A1,D1,F1") '　No.5 での追加オーダー　の場合
'　　Const fSRef = "A1,B1,C1"　　'　原質問　の場合
Dim arrRef() As String
Dim wsh As Worksheet
Dim HAlignB As Excel.XlHAlign
Dim HAlignC As Excel.XlHAlign

If Intersect(Range(fSRef), Target(1)) Is Nothing = False Then

arrRef() = Split(fSRef, ",")

Application.EnableEvents = False
'For Each wsh In Sheets(Array("sheet2", "sheet3"))
' wsh.Cells(Target.Row, Target.Column).Value = Target(1).Value
' Next
Application.EnableEvents = True

If LenB(Range(arrRef(1))) = 0 Then
HAlignC = xlHAlignRight
Else
HAlignC = xlHAlignLeft
End If
If LenB(Range(arrRef(0))) = 0 Then
HAlignB = xlHAlignRight
Else
HAlignB = xlHAlignCenter
End If
For Each wsh In Sheets(Array("sheet1", "sheet2", "sheet3"))
wsh.Range(arrRef(1)).HorizontalAlignment = HAlignB
wsh.Range(arrRef(2)).HorizontalAlignment = HAlignC
Next

ElseIf Intersect(Range(fSRef1), Target(1)) Is Nothing = False Then

arrRef() = Split(fSRef1, ",")

Application.EnableEvents = False
' For Each wsh In Sheets(Array("sheet2", "sheet3"))
' wsh.Cells(Target.Row, Target.Column).Value = Target(1).Value
' Next
Application.EnableEvents = True

If LenB(Range(arrRef(1))) = 0 Then
HAlignC = xlHAlignRight
Else
HAlignC = xlHAlignLeft
End If
If LenB(Range(arrRef(0))) = 0 Then
HAlignB = xlHAlignRight
Else
HAlignB = xlHAlignCenter
End If
For Each wsh In Sheets(Array("sheet1", "sheet2", "sheet3"))
wsh.Range(arrRef(1)).HorizontalAlignment = HAlignB
wsh.Range(arrRef(2)).HorizontalAlignment = HAlignC
Next

End If

End Sub
--------------------------------------------------------------------------------------

「D13,G13,I13」「A1,D1,F1」と2箇所ほしかったので、いろいろ調べてみまして

If Intersect(Range(fSRef), Target(1)) Is Nothing = False Then
・
・
elseif　Intersect(Range(fSRef1), Target(1)) Is Nothing = False Then
・
・
endif

というふうにして、うまくいきました。

また
--------------------------------------------------------
Application.EnableEvents = False
For Each wsh In Sheets(Array("sheet2", "sheet3"))
wsh.Cells(Target.Row, Target.Column).Value = Target(1).Value
Next
Application.EnableEvents = True
------------------------------------------------------------------------
の箇所では、すでに入力している「A1：E3」の２つの結合セルを選択して「DELETE」を押しますと
sheet1は２つの結合セルに入力した値が消えますが、sheet2,sheet3では、「D1:E3」の結合セルの値が削除
されませんでした。

そこで、あえて上記のコードをいったんとめて
sheet2,sheet3には入力するセル全部に「=Sheet1!A1」というふうにしてリンクすることで解決いたしました。

また、当初は
------------------------------------
If Range(arrRef(1)).Value = 0 Then
------------------------------------
------------------------------------
If Range(arrRef(1)).Value = "" Then
------------------------------------
としていたのですが
たとえば
A1 B1 C1
10 000 123

と入力した場合、B1には「000」と入力しているけど
上記では「なにも入力されていない」と判断され、「HAlignC = xlHAlignRight」を返されて都合が悪くなりました。

そこで、なにかいい方法はないかといろいろ調べてみまして
LenB関数がセルのバイト数を返すのを見つけて、これだったらもしかしたらいけるかもと思い、試してみました。

結果、うまくいきました。

cj_moverさんにお力添えをいただいたおかげで、期待どおりの動作をするようになりました。
ほんとうにありがとうございました。

回答No.6

cj_mover

先頃、帰宅しました。
＃２-５、ｃｊです。
＃５補足欄へのレスです。

修正の件、
惜しい。もう少しでしたね。
修正ポイント、★マークにしています。
見比べて確認してみてください。
# それから、気にしなくていいですよ。＾＾
何か疑問が残っているなら訊いといて貰った方がありがたい位です。
では、また。

' ' 〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓

' ' 以下、Sheet1モジュール　' cj8271875_3.5

Private Sub Worksheet_Change(ByVal Target As Range)
　　If Target.Row > 1 Then Exit Sub
　　If Target.Column > 6 Then Exit Sub　　'　　★

　　Dim wsh As Worksheet
　　Dim r As Range

　　With Range("F1")　　'　　★
　　　　If Range("D1").Value = "" Then　　'　　★
　　　　　　.HorizontalAlignment = xlHAlignRight
　　　　Else
　　　　　　.HorizontalAlignment = xlHAlignLeft
　　　　End If
　　End With

　　With Range("D1")　　'　　★
　　　　If Range("A1").Value = "" Then
　　　　　　.HorizontalAlignment = xlHAlignRight
　　　　Else
　　　　　　.HorizontalAlignment = xlHAlignCenter
　　　　End If
　　End With

　　Application.EnableEvents = False
　　On Error GoTo ErrHndl_
　　For Each wsh In Sheets(Array("Sheet2", "Sheet3"))
　　　　For Each r In Range("A1,D1,F1")　　'　　★
　　　　　　r.MergeArea.Copy Destination:=wsh.Cells(r.Column)
　　　　Next
　　Next
　　Application.EnableEvents = True

　　Exit Sub
ErrHndl_:
　　MsgBox "シート：　" & wsh.Name & vbLf & "セル範囲：" & r.Column & " 列め" _
　　　　& vbLf & vbTab & "への貼付けが失敗しました。" _
　　　　& vbLf & "異なるサイズの結合セルへ貼付けようとしているようです。" _
　　　　& vbLf & vbLf & "実行時エラー'" & Err & vbLf & Err.Description, vbExclamation
　　　　Resume Next
End Sub

' ' 〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓

' ' 以下、Sheet1モジュール　' cj8271875_4.5

Private Sub Worksheet_Change(ByVal Target As Range)
　　If Target.Row > 1 Then Exit Sub
　　If Target.Column > 6 Then Exit Sub　　'　　★

　　Dim wsh As Worksheet
　　Dim HAlignB As Excel.XlHAlign
　　Dim HAlignC As Excel.XlHAlign

　　Application.EnableEvents = False
　　On Error GoTo ErrHndl_
　　For Each wsh In Sheets(Array("Sheet2", "Sheet3"))
　　　　wsh.Cells(Target.Column).Value = Target(1).Value
　　Next
　　On Error GoTo 0
　　Application.EnableEvents = True

　　If Range("D1").Value = "" Then　　'　　★
　　　　HAlignC = xlHAlignRight
　　Else
　　　　HAlignC = xlHAlignLeft
　　End If
　　If Range("A1").Value = "" Then
　　　　HAlignB = xlHAlignRight
　　Else
　　　　HAlignB = xlHAlignCenter
　　End If
　　For Each wsh In Sheets(Array("Sheet1", "Sheet2", "Sheet3"))
　　　　wsh.Range("D1").HorizontalAlignment = HAlignB　　'　　★
　　　　wsh.Range("F1").HorizontalAlignment = HAlignC　　'　　★
　　Next

　　Exit Sub
ErrHndl_:
　　MsgBox "シート：　Sheet1" & vbLf & "セル範囲：" & Target(1).Address(0, 0) _
　　　　& vbLf & vbTab & ".Valueプロパティの取得" & vbLf & "　　または" _
　　　　& vbLf & "シート：　" & wsh.Name & vbLf & "セル範囲：" & Target(1).Address(0, 0) _
　　　　& vbLf & vbTab & ".Valueプロパティの設定" & vbLf & "　　に失敗しました。" _
　　　　& vbLf & vbLf & "実行時エラー'" & Err & vbLf & Err.Description, vbExclamation
　　Resume Next
End Sub

' ' 〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓

補足

cj_moverさまへ
お返事が遅くなり、申し訳ございません。

早急なご回答をくださいまして、ほんとうにありがとうございます。

また、「気にしなくていいですよ」と言ってくださいましたこと
とてもうれしかったです。

教えていただいたコード、「cj8271875_3.5」「 cj8271875_4.5」を試してみましたところ
パターン２の結合セルでも無事に動くようになりました！（^^）

ありがとうございます。

ただ、今回つくっていたエクセルBOOKで、A1:I3につくっていたところを
C13:K15にもっていかないといけなくなってしまいました。

そこで、下記のコードにそれぞれ修正してみました。

■cj8271875_3.5

---------------------------------------------------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
'If Target.Row > 1 Then Exit Sub
'If Target.Column > 6 Then Exit Sub '　　★

Dim wsh As Worksheet
Dim r As Range

With Range("h13") '　　★
If Range("f13").Value = "" Then '　　★
.HorizontalAlignment = xlHAlignRight
Else
.HorizontalAlignment = xlHAlignLeft
End If
End With

With Range("f13") '　　★
If Range("c13").Value = "" Then
.HorizontalAlignment = xlHAlignRight
Else
.HorizontalAlignment = xlHAlignCenter
End If
End With

Application.EnableEvents = False
On Error GoTo ErrHndl_
For Each wsh In Sheets(Array("Sheet2", "Sheet3"))
For Each r In Range("c13,f13,h13") '　　★
r.MergeArea.Copy Destination:=wsh.Cells(r.Column)
Next
Next
Application.EnableEvents = True

Exit Sub
ErrHndl_:
MsgBox "シート：　" & wsh.Name & vbLf & "セル範囲：" & r.Column & " 列め" _
& vbLf & vbTab & "への貼付けが失敗しました。" _
& vbLf & "異なるサイズの結合セルへ貼付けようとしているようです。" _
& vbLf & vbLf & "実行時エラー'" & Err & vbLf & Err.Description, vbExclamation
Resume Next
End Sub
---------------------------------------------------------------------------------------

こちらを実行してみましたところ

sheet1は正常だったのですが
sheet2,sheet3では、「C1:E3」「F1:G3」「H1：K3」の結合セルが作成されて
そのなかにsheet1で入力した数字がコピーされていました。

■cj8271875_4.5
------------------------------------------------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
'If Target.Row > 1 Then Exit Sub
'If Target.Column > 6 Then Exit Sub '　　★

Dim wsh As Worksheet
Dim HAlignB As Excel.XlHAlign
Dim HAlignC As Excel.XlHAlign

Application.EnableEvents = False
On Error GoTo ErrHndl_
For Each wsh In Sheets(Array("Sheet2", "Sheet3"))
wsh.Cells(Target.Column).Value = Target(1).Value
Next
On Error GoTo 0
Application.EnableEvents = True

If Range("f13").Value = 0 Then '　　★
HAlignC = xlHAlignRight
Else
HAlignC = xlHAlignLeft
End If
If Range("c13").Value = 0 Then
HAlignB = xlHAlignRight
Else
HAlignB = xlHAlignCenter
End If
For Each wsh In Sheets(Array("Sheet1", "Sheet2", "Sheet3"))
wsh.Range("f13").HorizontalAlignment = HAlignB '　　★
wsh.Range("h13").HorizontalAlignment = HAlignC '　　★
Next

Exit Sub
ErrHndl_:
MsgBox "シート：　Sheet1" & vbLf & "セル範囲：" & Target(1).Address(0, 0) _
& vbLf & vbTab & ".Valueプロパティの取得" & vbLf & "　　または" _
& vbLf & "シート：　" & wsh.Name & vbLf & "セル範囲：" & Target(1).Address(0, 0) _
& vbLf & vbTab & ".Valueプロパティの設定" & vbLf & "　　に失敗しました。" _
& vbLf & vbLf & "実行時エラー'" & Err & vbLf & Err.Description, vbExclamation
Resume Next

End Sub

--------------------------------------------------------------------------------------------------------------

sheet1では、正常なのですが
sheet2,sheet3では、sheet1で入力した数字が「C1」「F1」「H1」に入力されてしまいました。

「cj8271875_3.5」「 cj8271875_4.5」の下記のところで

r.MergeArea.Copy Destination:=wsh.Cells(r.Column)
wsh.Cells(Target.Column).Value = Target(1).Value

offsetをつけてみたり、Target(1)の箇所をいろいろ変更してみましたが
解決できませんでした。

上記についてご教授いただけますと、とてもうれしく思いますm(_ _)m

回答No.5

cj_mover

＃２-４、ｃｊです。
＃４の続きです。

ちょっとやそっとエラーにならない堅い書き方も挙げておきます。
もう少しシンプルに書きたい感じはしますし、
逆に、もっと変数増やして丁寧に書きたい感じもしますが、
処理自体は寧ろこれまでのものより軽くなっています。
.Value プロパティ と .HorizontalAlignment プロパティ
にしか触って（変更を加えて）いませんから、
（UserInterfaceOnly 未設定にて）シートの保護でもしない限り、
エラーは相当に考え難いです。
特に説明しませんけれど、何かあったら訊いてください。
# えーと、どれを選ぶもご自由に＾＾どうぞ。

Sheet2, Sheet3 にて、Worksheet_Change イベントを使っていなければ、
▼マークの行（２カ所）は不要です。

エラートラップ、必要とは思えないので、
もし、そちらで判断できましたら、
◆マークの行（６カ所）は削除して構いません。

' ' 以下、Sheet1モジュール　' cj8271875_4

Private Sub Worksheet_Change(ByVal Target As Range)
　　If Target.Row <> 1 Then Exit Sub
　　If Target.Column > 3 Then Exit Sub

　　Dim wsh As Worksheet
　　Dim HAlignB As Excel.XlHAlign
　　Dim HAlignC As Excel.XlHAlign

　　' ' Sheet2, Sheet3 .Valueを設定
　　Application.EnableEvents = False　　'　　▼
　　On Error GoTo ErrHndl_　　'　　◆
　　For Each wsh In Sheets(Array("Sheet2", "Sheet3"))
　　　　wsh.Cells(Target.Column).Value = Target(1).Value
　　Next
　　On Error GoTo 0　　'　　◆
　　Application.EnableEvents = True　　'　　▼

　　' ' Sheet1, Sheet2, Sheet3 .HorizontalAlignmentを設定
　　If Range("B1").Value = "" Then
　　　　HAlignC = xlHAlignRight
　　Else
　　　　HAlignC = xlHAlignLeft
　　End If
　　If Range("A1").Value = "" Then
　　　　HAlignB = xlHAlignRight
　　Else
　　　　HAlignB = xlHAlignCenter
　　End If
　　For Each wsh In Sheets(Array("Sheet1", "Sheet2", "Sheet3"))
　　　　wsh.Cells(2).HorizontalAlignment = HAlignB
　　　　wsh.Cells(3).HorizontalAlignment = HAlignC
　　Next

　　Exit Sub　　'　　◆
ErrHndl_:　　'　　◆　　←↓
　　MsgBox "シート：　Sheet1" & vbLf & "セル範囲：" & Target(1).Address(0, 0) _
　　　　& vbLf & vbTab & ".Valueプロパティの取得" & vbLf & "　　または" _
　　　　& vbLf & "シート：　" & wsh.Name & vbLf & "セル範囲：" & Target(1).Address(0, 0) _
　　　　& vbLf & vbTab & ".Valueプロパティの設定" & vbLf & "　　に失敗しました。" _
　　　　& vbLf & vbLf & "実行時エラー'" & Err & vbLf & Err.Description, vbExclamation
　　Resume Next　　'　　◆
End Sub

補足

cj_moverさまへ

早急なお返事をいただきまして、ほんとうにありがとうございます。

No.4で教えていただいたコードを試してみましたところ、エラーなく
バッチリ動くようになりました！

また、お礼を書きかけ中に、No.5のお返事をいただきまして、本当に感謝しております。
No.5も同様にバッチリ動きました。

ほんとうにありがとうございます。

けれど、数字を打つところが2パターンありまして、そのひとつが、いま解決しましたA1:A2の結合セル、B1:B2の結合セル、C1:C2の結合セルです。

そして、もうひとつのパターンが、A1:C3の結合セル、D1：E3の結合セル、F1:I3の結合セルです。

シート内で見たとき、A1:C3、D1:E3、F1:I3の結合セルのサイズは違いますが
A1:C3の結合セル、D1：E3の結合セル、F1:I3の結合セルのサイズはsheet1～sheet3でおなじです。

上記の結合セルのもと、No.4でご教授いただいたコードを下記のように一部変更して試してみましたところ、機能はするのですが、そのつど
--------------------------------------------------
シート：sheet2
セル範囲：2列め
への貼り付けが失敗しました。
異なるサイズの結合セルへ貼り付けようとしているようです。

実行時エラー’1004
結合されたセルの一部を変更することはできません。
--------------------------------------------------------
がでてしまいました。

----------------------------------------------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)

Dim wsh As Worksheet
Dim r As Range

With Range("f1")
If Range("d1").Value = 0 Then
.HorizontalAlignment = xlHAlignRight
Else
.HorizontalAlignment = xlHAlignLeft
End If
End With

With Range("d1")
If Range("A1").Value = 0 Then
.HorizontalAlignment = xlHAlignRight
Else
.HorizontalAlignment = xlHAlignCenter
End If
End With

Application.EnableEvents = False
On Error GoTo ErrHndl_
For Each wsh In Sheets(Array("Sheet2", "Sheet3"))
For Each r In Range("A1:f1")
r.MergeArea.Copy Destination:=wsh.Cells(r.Column)
Next
Next
Application.EnableEvents = True

Exit Sub
ErrHndl_:
MsgBox "シート：　" & wsh.Name & vbLf & "セル範囲：" & r.Column & " 列め" _
& vbLf & vbTab & "への貼付けが失敗しました。" _
& vbLf & "異なるサイズの結合セルへ貼付けようとしているようです。" _
& vbLf & vbLf & "実行時エラー'" & Err & vbLf & Err.Description, vbExclamation
Resume Next
End Sub

------------------------------------------------------------------------------------

教えていただいたNo.5のコードをおなじく下記のコードにしてみましたところ、
上記のようなエラーはでなかったのですが、セルの文字揃えがうまく機能しなくなってしまいました。

-------------------------------------------------------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)

Dim wsh As Worksheet
Dim HAlignB As Excel.XlHAlign
Dim HAlignC As Excel.XlHAlign

' ' Sheet2, Sheet3 .Valueを設定
Application.EnableEvents = False '　　▼
On Error GoTo ErrHndl_ '　　◆
For Each wsh In Sheets(Array("Sheet2", "Sheet3"))
wsh.Cells(Target.Column).Value = Target(1).Value
Next
On Error GoTo 0 '　　◆
Application.EnableEvents = True '　　▼

' ' Sheet1, Sheet2, Sheet3 .HorizontalAlignmentを設定
If Range("d1").Value = 0 Then
HAlignC = xlHAlignRight
Else
HAlignC = xlHAlignLeft
End If
If Range("A1").Value = 0 Then
HAlignB = xlHAlignRight
Else
HAlignB = xlHAlignCenter
End If
For Each wsh In Sheets(Array("Sheet1", "Sheet2", "Sheet3"))
wsh.Cells(2).HorizontalAlignment = HAlignB
wsh.Cells(3).HorizontalAlignment = HAlignC
Next

Exit Sub '　　◆
ErrHndl_: '　　◆　　←↓
MsgBox "シート：　Sheet1" & vbLf & "セル範囲：" & Target(1).Address(0, 0) _
& vbLf & vbTab & ".Valueプロパティの取得" & vbLf & "　　または" _
& vbLf & "シート：　" & wsh.Name & vbLf & "セル範囲：" & Target(1).Address(0, 0) _
& vbLf & vbTab & ".Valueプロパティの設定" & vbLf & "　　に失敗しました。" _
& vbLf & vbLf & "実行時エラー'" & Err & vbLf & Err.Description, vbExclamation
Resume Next '　　◆
End Sub

---------------------------------------------------------------------------------------

最初のパターンで、結合セルが解決できると、もうひとつのパターンの結合セルでも機能すると安易に考えていたため、cj_moverさんにもうひとつのパターンについて伝えておらず、たいへん申し訳ございませんでした。

もし伝えていたら、そのことも考慮されてコードを書かれていたと思いますので、お手間をとらせてしまいました。

もうひといきの感じがしますので、ご教授いただけますと幸いです。

回答No.4

cj_mover

＃２、３、ｃｊです。
＃３、補足欄へのレスです。

まずは、すみません、ミス（ポカ）してました。
　　　　Range("A1:A3").Copy Destination:=wsh.Range("A1")
ではなくて、意図したのは（実際にテストしていた記述は）、
　　　　Range("A1:C1").Copy Destination:=wsh.Range("A1")
でした。ごめんなさい。
-----------------------------------------------------------------
実行時エラー'1004'：
結合されたセルの一部を変更することはできません。
-----------------------------------------------------------------
Excel2010であらためて確認してみましたが、
補足いただいた条件では、
　　　　Range("A1:C1").Copy Destination:=wsh.Range("A1")
または、
　　　　Range("A1:C2").Copy Destination:=wsh.Range("A1")
のような記述で問題なく処理されます。
もし、それでも、そのエラーが出るとすると、
原因候補１◆３つの結合セルのサイズが異なる場合、
原因候補２◆３つのシート間でそれぞれの結合セルのサイズが異なる場合、
という風に原因は限定されます。

とりあえず、原因候補１◆だけ対策してみます。
一応エラートラップ掛けました。
混乱するといけないので、既出のコードは削除して試してください。

' ' 以下、Sheet1モジュール　' cj8271875_3

Private Sub Worksheet_Change(ByVal Target As Range)
　　If Target.Row <> 1 Then Exit Sub
　　If Target.Column > 3 Then Exit Sub

　　Dim wsh As Worksheet
　　Dim r As Range

　　With Range("C1")
　　　　If Range("B1").Value = "" Then
　　　　　　.HorizontalAlignment = xlHAlignRight
　　　　Else
　　　　　　.HorizontalAlignment = xlHAlignLeft
　　　　End If
　　End With

　　With Range("B1")
　　　　If Range("A1").Value = "" Then
　　　　　　.HorizontalAlignment = xlHAlignRight
　　　　Else
　　　　　　.HorizontalAlignment = xlHAlignCenter
　　　　End If
　　End With

　　Application.EnableEvents = False
　　On Error GoTo ErrHndl_
　　For Each wsh In Sheets(Array("Sheet2", "Sheet3"))
　　　　For Each r In Range("A1:C1")
　　　　　　r.MergeArea.Copy Destination:=wsh.Cells(r.Column)
　　　　Next
　　Next
　　Application.EnableEvents = True

　　Exit Sub
ErrHndl_:
　　MsgBox "シート：　" & wsh.Name & vbLf & "セル範囲：" & r.Column & " 列め" _
　　　　& vbLf & vbTab & "への貼付けが失敗しました。" _
　　　　& vbLf & "異なるサイズの結合セルへ貼付けようとしているようです。" _
　　　　& vbLf & vbLf & "実行時エラー'" & Err & vbLf & Err.Description, vbExclamation
　　　　Resume Next
End Sub

原因候補２◆については、
もしも、そういう事なら前提から違ってくるので、アプローチを変えてみようかな？
と迷う点もありますので、あらためて補足ください。

回答No.3

cj_mover

＃２、ｃｊです。お礼欄へのレスです。

Ａ１、Ｂ１、Ｃ１、の３セルにそれぞれ
値を設定してあるかどうか、という点だけみると
２＊２＊２、で、８通りになりますが、
説明されているのは３通り、ご提示のコードでは４通りです。
それで十分成立している、ということなのでしょうし、
この条件下で成立するマクロは書けているのですが、
「それ以外の場合の処理」って、
ＶＢＡを書く上では必ず確認する必要があるものです。

今後新たに手を加える必要もあるでしょうから、今の段階では、
元々ご提示のコード内容に沿った書き方を提示しておきます。

一点だけ注意として、
　Sheet1 の A1:C1 を丸ごとコピーしたものを
　Sheet2 Sheet3 の A1 に貼り付ける
という処理に書き直しました（∵記述がシンプルになるので）。
この場合、それぞれのシートで
結合セルのサイズが異なっていたりするとエラーになりますが、
敢えてエラートラップを掛けていません。
> シート２、シート３は、A1～C1のセルがシート1とおなじように結合されています。
という説明があるので、サイズも同じだとは思いますが、
もし、こういう理由でエラーになってしまった場合は、
　　　　Range("A1:A3").Copy Destination:=wsh.Range("A1")
この ↑ 行で、止まってしまうので、
イベントが発生しなくなってしまい以後このマクロは動きませんから、
とりあえず、Ｅｘｃｅｌを閉じて開き直すようにしてください。

' ' 以下、Sheet1モジュール　' cj8271875_2

Private Sub Worksheet_Change(ByVal Target As Range)
　　If Target.Row <> 1 Then Exit Sub
　　If Target.Column > 3 Then Exit Sub

　　Dim wsh As Worksheet

　　With Range("C1")
　　　　If Range("B1").Value = "" Then
　　　　　　.HorizontalAlignment = xlHAlignRight
　　　　Else
　　　　　　.HorizontalAlignment = xlHAlignLeft
　　　　End If
　　End With

　　With Range("B1")
　　　　If Range("A1").Value = "" Then
　　　　　　.HorizontalAlignment = xlHAlignRight
　　　　Else
　　　　　　.HorizontalAlignment = xlHAlignCenter
　　　　End If
　　End With

　　Application.EnableEvents = False
　　For Each wsh In Sheets(Array("Sheet2", "Sheet3"))
　　　　Range("A1:A3").Copy Destination:=wsh.Range("A1")
　　Next
　　Application.EnableEvents = True
End Sub

補足

cj_moverさまへ

ご回答ありがとうございます。

cj_moverさんの教えていただいたコードについていろいろと調べて
書かれてある内容について自分なりに理解することができました。

そのうえで、No.３でcj_moverさんから教えていただいたコードをsheet1モジュールに入れてみたのですが、セルが結合されていたら下記のエラーが出てしまいます。

-----------------------------------------------------------------
実行時エラー'1004'：
結合されたセルの一部を変更することはできません。
-----------------------------------------------------------------

エラー箇所は、cj_moverさんが注意として教えてくださった
----------------------------------------------
Range("A1:C1").Copy Destination:=wsh.Range("A1")
-------------------------------------------------
のところです。

セルの結合を解除して試したところ、A1、B1、C1は、わたしの求めていた動作をしました。

ためしに、新しく「新規作成」をして
sheet1,sheet2,sheet3に
A1：A2を選択して、「セルを結合して中央揃え」
B1:B2を選択して、「セルを結合して中央揃え」
C1:C2を選択して、「セルを結合して中央揃え」

として、教えていただいたコードをsheet1モジュールに入れてみても同様のエラーが出てしまいます。

以前、下記の質問をさせていただいたときも結合セルがネックになったことがありました。

http://oshiete.goo.ne.jp/qa/8226147.html
http://oshiete.goo.ne.jp/qa/8241405.html　 の　No.2

上記URLをヒントに

Range("A1:C1").cell(1).Copy Destination:=wsh.Range("A1").cell(1)
Range("A1:C1").cell(1).MergeArea.Copy Destination:=wsh.Range("A1").cell(1).MergeArea

など、いろいろと試してみましたが、解決できませんでした。

なにか解決案がございましたら、ご教授してくださいますと幸いです。
どうかよろしくお願いいたします。

回答No.2

cj_mover

こんにちは。お邪魔します。

最初は私も、Sheet1:SHeet3を作業グループにする方法を考えていたのですが、
他の処理に影響を与えないように書くのが、かなり手間が掛かりますので、
ベタにシートをループした方が良いと判断しました。

　以下、理由。というか言い訳？
　例えば、Ａ１に"hoge"とか入力してEnterしたとして、
　処理後の選択範囲やアクティブセルをどうするか？
　例えば、Ａ１選択中にDelキーを押した時は選択を変えない、
　Ａ１を編集状態で値を空にしてEnterした場合はひとつ下のセルとか、
　いやいや設定によってはひとつ右だとか、、、。
　そもそもＶＢＡでコマンドされた値変更の場合、
　Selectionがセル範囲じゃなかったらどうする？Sheet2が選択中だったら？
　等々、手当てを考えるとキリがないのです。
　といって、現状維持をキチンとしないと、
　Select メソッドを使っているＶＢＡユーザーにとっては、
　他の処理でエラーを招く原因になりますから。

率直に言って、質問者さんにとっては実力を超えた難しい処理をしようとしているんだと思います。
決して易しく書けるものではないので、こちらが提示するものも、それなりです。
ただ、なるべくエラーフリーな書き方となると、これより簡単には書けないと思います。
以下、細かい解説はしません。
解らない部分は、まず、調べて、それでもお困りでしたら、
遠慮なく、お尋ねください。

一応、説明がなかったので、こちらで未確認のポイントとして、
　Sheet1 の
　　A1 の値が変更されたら、Sheet1:Sheet3 のB1
　　B1 の値が変更されたら、Sheet1:Sheet3 のC1
　　の書式を変更する。
　.HorizontalAlignmenだけではなくて、.VerticalAlignmentも設定する。
という理解でいます。

こちらで追加した条件として
　　「　A1 【だけ】　」の値が変更されたら、、、
　　「　B1 【だけ】　」の値が変更されたら、、、
という風にしています。
Ａ列まるごと消去、などのタイミングでは、機能しないようにしています。

Sub HorizontalAndVerticalAlignmentSamp9()　　の引数について
　Address　必ず指定します。Sheet1:Sheet3で書式を設定するべきセルの.Addressを"A1形式"で・
　VAlign　省略可能です。.VerticalAlignmentの引数に渡す値を指定します。この引数を省略した場合は.VerticalAlignmentを設定しません。
　HAlign　省略可能です。.HorizontalAlignmentの引数に渡す値を指定します。この引数を省略した場合は.HorizontalAlignmentを設定しません。

' ' 以下、Sheet1モジュール　' cj8271875

Private Sub Worksheet_Change(ByVal Target As Range)
　　If Target.Row <> 1 Then Exit Sub
　　If Target.Column > 2 Then Exit Sub

　　If Target(1).Value = "" Then
　　　　If Target.Address <> Target(1).MergeArea.Address Then Exit Sub
　　　　Call HorizontalAndVerticalAlignmentSamp9(Target.Offset(, 1).Address, , xlHAlignRight)
　　Else
　　　　If Target.Count > 1 Then Exit Sub
　　　　Call HorizontalAndVerticalAlignmentSamp9(Target.Offset(, 1).Address, , xlHAlignLeft)
　　End If
End Sub

Sub HorizontalAndVerticalAlignmentSamp9( _
　　　　ByVal Address As String, _
　　　　Optional ByVal VAlign As Excel.XlHAlign, _
　　　　Optional ByVal HAlign As Excel.XlVAlign _
　　　　)
　　Dim wsh As Worksheet

　　For Each wsh In Sheets(Array("Sheet1", "Sheet2", "Sheet3"))
　　　　With wsh.Range(Address)
　　　　　　If VAlign <> 0 Then .VerticalAlignment = VAlign
　　　　　　If HAlign <> 0 Then .HorizontalAlignment = HAlign
　　　　End With
　　Next
End Sub

お礼

cj_moverさまへ
ご回答をいただきまして、ほんとうにありがとうございます。

＞一応、説明がなかったので、こちらで未確認のポイントとして、
＞　Sheet1 の
＞　　A1 の値が変更されたら、Sheet1:Sheet3 のB1
＞　　B1 の値が変更されたら、Sheet1:Sheet3 のC1
＞　　の書式を変更する。
＞　.HorizontalAlignmenだけではなくて、.VerticalAlignmentも設定する。
＞という理解でいます。

このたびは、わたしの説明が不十分で、申し訳ございませんでした。

質問文では、“文字”と一言で書きましたが正確には数字のみの入力になります。
C1のセルでは最大100の位の数字を入力します。
B1のセルでは最大10万の位の数字を入力します。
A1のセルでは最大1000万の位の数字を入力します。

例）
A1　　　B1　　　C1
10　　　000　　　000
　　　　10　　　000
　　　　　　　　300

たとえば、「300」の数字の場合は、B1、A1のセルは未入力でC1は右揃えにしたいです。
また、「10000」の数字を入力する場合は、C1は左揃えに、B1は右揃えにしたいです。（C1が右揃え、B1が中央揃えとかだと、数字のバランスが不自然なため）
つぎに、「10000000」の数字を入力する場合は、C1は左揃えに、B1は中央揃えに、A1は右揃えにしたいです。

そして、上記の数字をsheet1に入力したら、自然にsheet2、sheet3にも反映されているようにできるとうれしいです。

vbaの知識がまだまだ未熟なため、いまはcj_moverさんが書かれた上記のコードの意味や意図を１つ１つ調べて、日本語で書いてみているところです。

調べていく段階で、いろいろとわからないところがでてくると思いますが、そのときは、お言葉に甘えまして、聞いてみたいと思います。

ありがとうございました。

回答No.1

web2525

マクロの中にシートの指定がないので、実行はアクティブシートでしか反映されない
Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Select
複数のシートを選択するコードを追加することで解決するかと思われます

お礼

web2525さまへ
ご回答くださいまして、ほんとうにありがとうございます。

vbaは、まだまだ初心者でして、上記のコードがどういった機能をしているのかわからなかったので、さっそく調べてみました。

そして、配列というのを利用して、sheet1、sheet2、sheet3の３つのシートを複数選択する――ということを知りました。

エクセルを利用していたときも、sheet1を選択している状態で、シフトキーを押しながらsheet3を押すと、３つのシートを複数選択することができることは知っていたのですが、３つ選択した状態で、セルに文字を入力すると、３つのシートに反映されるというのは知らなかったので、１つ勉強になりました。
ありがとうございます。

そのことを踏まえまして、上記のコードを入れてみました。
結果、sheet1～sheet3に文字が反映したのですが、sheet1～sheet3の文字揃えがなぜかうまくリンクしてくれませんでした。

if～end ifの条件式のやり方辺りに問題があるような気がしますが、もう少しいろいろと考えてみようと思います。

ほんとうにありがとうございました。