VBA,二つのExcelのsheetにデータ保存

質問

VBA初心者です。
皆様のお力をお貸し頂きたく質問させて頂きます。よろしくお願いいたします。

質問内容は、下記になります。

Excelのsheet1には、縦列A,B,C・・・とデータが入っております。
sheet1の例
A B C

sheet2は、入力するsheetです。
今回はA列の3行目からとします。

問題は、sheet1の縦の列をA,B,C,Dとすればデータの更新は、出来るのですが
sheet1のデータのA,B,C一つ飛んでEまた一つ飛んでGという感じでsheet1のデータを
飛ばしてsheet2に表示、更新(保存)をしたいと思います。

ですので、sheet2のA列の3行目からA,B,C,飛んでE飛んでGとsheet１からデータを
表示させ、さらにsheet2の入力値が変更されると、sheet1のデータが入っている
A,B,C,E,Gに更新される仕様です。

sheet1（データが入っています）
A , B , C , E , G ,
値1 , 値2 , 値3　　 , 値4 , 値5

sheet2(入力する、入力したデータは、sheet1へ更新される)
A列
3行目　、sheet1の値1(A列)が入ります。
4行目　、sheet1の値2(B列)が入ります。
5行目　、sheet1の値3(C列)が入ります。
6行目　、sheet1の値4(E列)が入ります。
7行目　、sheet1の値5(G列)が入ります。

以上です。申し訳ございませんが、ご教授よろしくお願いいたします。

回答No.1

tom04 · ベストアンサー

こんばんは！

両Sheetとも1行または1列だけの操作で良い！という解釈です。
VBAになりますが、一例です。
↓の画像のように左側がSheet1・右側がSheet2とします。

まず画面左下のシート見出しの「Sheet1」上で右クリック　→　コードの表示　→　VBE画面のカーソルが点滅しているところに
↓のコードをコピー＆ペースト

Private Sub Worksheet_Change(ByVal Target As Range) 'この行から
Dim wS2 As Worksheet
Set wS2 = Worksheets("Sheet2")
If Intersect(Target, Range("A1:C1,E1,G1")) Is Nothing Then Exit Sub
Application.EnableEvents = False
With Target
Select Case .Column
Case Is <= 3
wS2.Cells(.Column + 2, "A") = .Value
Case 5
wS2.Range("A6") = .Value
Case Else
wS2.Range("A7") = .Value
End Select
End With
Application.EnableEvents = True
End Sub 'この行まで

次に「Sheet2」のシート見出し上で右クリック　→　コードの表示　→　・・・中略・・・　同様に
↓のコードをコピー＆ペーストし
両Sheetのデータを色々変更してみてください。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim wS1 As Worksheet
Set wS1 = Worksheets("Sheet1")
If Intersect(Target, Range("A3:A7")) Is Nothing Then Exit Sub
Application.EnableEvents = False
With Target
Select Case .Row
Case Is <= 5
wS1.Cells(1, .Row - 2) = .Value
Case 6
wS1.Range("E1") = .Value
Case Else
wS1.Range("G1") = .Value
End Select
End With
Application.EnableEvents = True
End Sub

こんな感じで良いのでしょうか？m(_ _)m

補足

tom04様

いつもお世話になっております。前回はありがとうございました。大変助かりました。

ご回答頂きありがとうございます。じつは、これも前回同様のExcelになります。
ですので、sheet1は複数行になります。

前回、教えて頂いたコードは、下記です。※現在は、仕様の理由により一部変更させて使用させて
頂いております。

'ワークシート内のセルに変更があった場合自動実行されます
'　→　変更されたセルがRange変数「Target」に代入されています
Private Sub Worksheet_Change(ByVal Target As Range)

'使用する変数の型を宣言(定義)
Dim myRng As Variant, mySt As Worksheet, tar As Range, i As Integer
Dim j As Integer
'変更されたセルの数が10個より大きい場合は終了
If Target.Count > 10 Then Exit Sub

'対象とするシートをオブジェクト変数へセット
Set mySt = Worksheets("DATA")

'変数Targetのセルを順次、変数myRngに格納しながら
'For～Next間をセルの数だけ繰り返し処理
For Each myRng In Target
'With～End Withまでの省略した場合のオブジェクト(ここではDATA Sheet)を指定
With mySt

'▼対象とするセルがセル範囲(D3:D5)内であれば処理
If Not Application.Intersect(myRng, Range("D3:D5")) Is Nothing Then
'変更されたセルの値でSheet1(の対象列)を検索して変数tarへ格納
Set tar = .Columns(myRng.Row - 2).Find(myRng.Value, , xlValues, _
xlWhole, xlByRows, xlPrevious, True, True, False)
'変更されたセルの行番号を変数iに格納
i = myRng.Row
'イベントを無効
'(セル内容の変更で自分自身が再度実行されないように無効化)
Application.EnableEvents = False
'Do～Loop間を繰り返し処理
Do
'変数iに1を加算、iが6になれば3に変更
i = i + 1: If i = 6 Then i = 3
'iが変更された行番号になればループから抜ける
If i = myRng.Row Then Exit Do
'検索結果によって出力結果を分岐
If tar Is Nothing Then
'検索結果が見つからなければ不明を出力
Cells(i, "D") = "不明"
Else
'見つかったセルと同じ行の対象項目の値を出力
Cells(i, "D") = .Cells(tar.Row, i - 2).Value
End If
Loop
'D列の6～17行目にSheet1(D～O列)のデータを出力
'G列の3～24行目にSheet1(P～AK列)のデータを出力
For j = 3 To 24
If tar Is Nothing Then
If 6 <= j And j <= 17 Then Cells(j, "D") = "不明"
Cells(j, "G") = "不明"
Else
If 6 <= j And j <= 17 Then _
Cells(j, "D") = .Cells(tar.Row, "D").Offset(0, j - 6).Value
Cells(j, "G") = .Cells(tar.Row, "P").Offset(0, j - 3).Value
End If
Next j
'イベントを再開
Application.EnableEvents = True

'▼対象とするセルがセル範囲(D6:D17又はG3:G24)内であれば処理
ElseIf (Not Application.Intersect(myRng, Range("D6:D17")) Is Nothing) _
Or (Not Application.Intersect(myRng, Range("G3:G24")) Is Nothing) Then
'検索セルtarが無い場合は検索
If tar Is Nothing Then
Set tar = .Columns("A").Find(Range("D3").Value, , xlValues, _
xlWhole, xlByRows, xlPrevious, True, True, False)
End If
'対象とするセルが変更可能のセル範囲であるかの判定
Application.EnableEvents = False
'▼対象とするセルがセル範囲(D6:D9)内であれば処理
If Not Application.Intersect(myRng, Range("D6:D9")) Is Nothing Then
'検索セルが見つからなければ不明、見つかれば値を戻して表示
If tar Is Nothing Then
myRng.Value = "不明"
Else
myRng.Value = .Cells(tar.Row, "D").Offset(0, myRng.Row - 6).Value
End If
'変更不可のメッセージを表示
MsgBox "対象のセル""" & myRng.Address(False, False) & """は変更できません"
'▼対象とするセルがセル範囲(D10:D17)内であれば処理
Else
'検索セルが見つからなければメッセージを表示
If tar Is Nothing Then
myRng.Value = "不明"
MsgBox "対象のセルが不明です"
'検索セルが見つかればDATA Sheetの範囲D～AKで該当項目の検索行を入力値で更新
Else
Select Case myRng.Column
Case 4 'D列(列番号4)が入力された場合
.Cells(tar.Row, "H").Offset(0, myRng.Row - 10) = myRng.Value
Case 7 'G列(列番号7)が入力された場合
.Cells(tar.Row, "P").Offset(0, myRng.Row - 3) = myRng.Value
End Select
End If
End If
Application.EnableEvents = True
End If

End With
Next
End Sub

sheet2のH行目の上から3行目から(H3からH12まで)個数を入力する為の行になります。
ですので、sheet1のDATAがAKからAUになった次第です。
前回、tom04様が作られた上記のコードのExcelシートの画像で説明させて頂きます。
sheet1のP行目からY行目までに、飛び飛びで縦に行を追加しました。10行分AUまでです。
ですので、Pの次がR(空欄ですが、個々に個数が入ります)で、次が、Tになり、それを
10行分追加しました。前回の画面で言うと表示的にはsheet2のG列3から24までになり、
G列のとなりH列に個数を入れるためH行目の3行目から12行目まで(そこには今回飛び飛びにsheet1に挿入
したある個数がはいります）sheet2のH行目もsheet1に値を更新させたいです。
sheet1に挿入した列は、Q,S,U,W,Y,AA,AC,AE,AG,AIです。(ここにある個数が入りますこれをsheet1の
H列の3行目から12行目です)
AJからAUまでは、連続したデータになっております。

度々、恐れ入りますが何卒ご協力お願いいたします。

回答No.2

tom04

No.1です。

補足を読ませていただきました。↓の質問に関連していたのですね？

http://okwave.jp/qa/q8801956.html

お示しのコードは　eden3616様が回答されたコードですね。
基本的に他の回答者様のコードに手を加えるのは失礼に当たると思いますので・・・
（色んなお考えがあってコードを記載されていると思います）

単刀直入に回答します。
結局今回の質問文と補足を自分なりに解釈すると
Sheet1のQ3～AI3セルの奇数列とSheet2のH3～H12セルの変化をそれぞれのセルに対応させたい！
という解釈です。

まずSheet1のシートモジュールのコードを次にように

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("Q3:AI3")) Is Nothing Then Exit Sub
If Target.Column Mod 2 = 1 Then
Application.EnableEvents = False
Worksheets("Sheet2").Cells((Target.Column - 11) / 2, "H") = Target.Value
Application.EnableEvents = True
End If
End Sub

次にSheet2のシートモジュールに↓のコードを次のようにしてください。

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("H3:H12")) Is Nothing Or Target.Count > 1 Then Exit Sub
Application.EnableEvents = False
Worksheets("Sheet1").Cells(3, 2 * Target.Row + 11) = Target.Value
Application.EnableEvents = True
End Sub

※　単に各Sheet変化があるたびに他のSheetのセルの値をそのセルの値にしているだけです。

補足にあるコードは詳しく検証していませんので
的外れならごめんなさいね。m(_ _)m

お礼

tom04様

いつもお世話になっております。大変失礼いたしました。申し訳ございません。
私の勘違いで。。。

度々のご回答頂き、ありがとうございます。少し上のコードを使わせて頂き検証いたしましたが
上手く動作してくれません。もう少し検証したいと思います。
本当に申し訳ございませんでした。

eden3616様大変失礼いたしました。申し訳ございませんでした。