Excel Q&Aサロン(VBA)

□ 戻る　 □一般操作のサロン　 □ 使用方法　 □ 新着記事　□ 新規に質問する！　 □ トピック一覧　 □ 検索　□ 過去ログ

[ 最新記事及び返信フォームをトピックトップへ ]

このトピック参照回数 :

2つのセルに入力して反映

[196160] 2つのセルに入力して反映

(2024/04/22(08:59))
□U R L/

[196161] Re[1]: 2つのセルに入力して反映

(2024/04/22(10:01))
□U R L/

１．当該シートの「シート見出し」を右クリックして、「コードの表示」を選ぶ（VBE画面になる）
２．画面中央の白いエリアに後記のマクロコードをコピペする。
３．ALT+F11キーを押下してエクセルに戻る

’コピペ用コード
　↓
Private Sub Worksheet_Change(ByVal Target As Range)
    Select Case Target.Address(0, 0)
        Case "L5"
            Application.EnableEvents = False
            Range("I16") = Target.Value
            Application.EnableEvents = True
        Case "I16"
            Application.EnableEvents = False
            Range("L5") = Target.Value
            Application.EnableEvents = True
    End Select
End Sub 

＞また、その反映されるタイミングはエンターで処理できるのか・・
指定したセルに新しい値を入力した時
(それが引き金となって実行される)


この記事にはVBAのコードが含まれています。

緑の太文字→注釈
茶色の太文字→条件分岐
赤の太文字→ループ
青の太文字→その他

[196162] Re[2]: 2つのセルに入力して反映

(2024/04/22(13:41))
□U R L/

おぉ！！出来ました！！！


ここでは、2つのセル　セルL5　セルI16と指定しましたが、

これを後、20ヶ所ほどのセルで行いのです。

とりあえず、下記のソースを作りましたが、これは、Loop?など使ってもう少しシンプルにすることは可能でしょうか？？



        Case "L5"       'A-B
            Application.EnableEvents = False
            Range("I16") = Target.Value
            Application.EnableEvents = True
        Case "I16"      'A-B
            Application.EnableEvents = False
            Range("L5") = Target.Value
            Application.EnableEvents = True
        Case "N5"       'B-A
            Application.EnableEvents = False
            Range("K16") = Target.Value
            Application.EnableEvents = True
        Case "K16"      'B-A
            Application.EnableEvents = False
            Range("N5") = Target.Value
            Application.EnableEvents = True
            
        Case "P5"       'A-C
            Application.EnableEvents = False
            Range("W16") = Target.Value
            Application.EnableEvents = True
        Case "W16"       'A-C
            Application.EnableEvents = False
            Range("P5") = Target.Value
            Application.EnableEvents = True
        Case "R5"       'C-A
            Application.EnableEvents = False
            Range("Y16") = Target.Value
            Application.EnableEvents = True
        Case "Y16"       'C-A
            Application.EnableEvents = False
            Range("R5") = Target.Value
            Application.EnableEvents = True

緑の太文字

茶色の太文字

赤の太文字

青の太文字

[196163] Re[3]: 2つのセルに入力して反映

(2024/04/22(15:28))
□U R L/

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim strAry(0 To 1)
    Dim Pos
    
    strAry(0) = Split("L5,N5,P5,R5", ",")
    strAry(1) = Split("I16,K16,W16,Y16", ",")
    
    Pos = Application.Match(Target.Address(0, 0), strAry(0), 0)
    
    If IsNumeric(Pos) Then
        Pos = Pos * 10 + 1 '1桁目は1。strAry(1)が転記先
    Else
        Pos = Application.Match(Target.Address(0, 0), strAry(1), 0)
        If IsNumeric(Pos) Then
            Pos = Pos * 10 '1桁目は0。strAry(0)が転記先
        Else
            Exit Sub
        End If
    End If
    
    Application.EnableEvents = False
        Range(strAry(Pos Mod 10)(Pos \ 10 - 1)) = Target.Value
    Application.EnableEvents = True
End Sub


この記事にはVBAのコードが含まれています。

緑の太文字→注釈
茶色の太文字→条件分岐
赤の太文字→ループ
青の太文字→その他

[196165] Re[4]: 2つのセルに入力して反映

(2024/04/23(11:13))
□U R L/

シンプルにする

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Ary As Variant
    Dim v As Variant
    
    Ary = Array("L5", "I16", "N5", "K16", "P5", "W16", "R5", "Y16")
    v = Application.Match(Target.Address(0, 0), Ary, 0)
    If IsNumeric(v) Then
        Application.EnableEvents = False
        Range(Ary(v - 2 * ((v + 1) Mod 2))).Value = Target.Value
        Application.EnableEvents = True
    End If
End Sub

組み合うセルアドレスを Array 関数内の
　　１番目の要素　と　２番目の要素
　　３番目の要素　と　４番目の要素
　　５・・・・・　と　６・・・・・　というルールで並べる

緑の太文字

茶色の太文字

赤の太文字

青の太文字


[196166] Re[5]: 2つのセルに入力して反映- ■ / 記事引用/メール受信=OFF■ □投稿者/ むみ -(2024/04/23(16:26)) □U R L/ お二方書き込み頂き　ありがとうございます！！配列の理解と、テストしておりまして、、今しばらく時間がかかりそうです。すみませんが、ちょっと試させてください。

[196167] Re[6]: 2つのセルに入力して反映

(2024/04/23(16:40))
□U R L/

[196168] Re[7]: 2つのセルに入力して反映

(2024/04/23(21:33))
□U R L/

どこかに、組み合うセルアドレスのデータは必要です。
シートをひとつ追加して（「DATA」というシート名として）、そこに

	A	B
1	T7	T24
2	X7	X24
3	AB7	AZ24
4	AF7	BD24
5	・・	・・

のようなデータを用意すれば、以下でも可能でしょう。

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Ary() As Variant
    Dim Rng As Range, c As Range
    Dim i As Long
    Dim v As Variant
    
    Set Rng = Worksheets("DATA").Cells.SpecialCells(xlCellTypeConstants)
    ReDim Ary(Rng.Cells.Count - 1)
    For Each c In Rng
        Ary(i) = c.Value
        i = i + 1
    Next
    v = Application.Match(Target.Address(0, 0), Ary, 0)
    If IsNumeric(v) Then
        Application.EnableEvents = False
        Range(Ary(v - 2 * ((v + 1) Mod 2))).Value = Target.Value
        Application.EnableEvents = True
    End If
End Sub

緑の太文字

茶色の太文字

赤の太文字

青の太文字


[196172] Re[8]: 2つのセルに入力して反映- ■ / 記事引用/メール受信=OFF■ □投稿者/ むみ -(2024/04/25(15:24)) □U R L/ なるほど！！大変参考になりました。詳しく丁寧にご教授頂きありがとうございました。助かりました。感謝です！！

[196173] Re[9]: 2つのセルに入力して反映

(2024/04/25(15:45))
□U R L/

一つ問題がおきました！！何度もすみません、

下記のソースにした場合
セルを空白（数値をクリア）にしても、反映されません、、

どなたかお助けください



Private Sub Worksheet_Change(ByVal Target As Range)
    Dim strAry(0 To 1)
    Dim Pos
    
    strAry(0) = Split("L5,N5,P5,R5", ",")
    strAry(1) = Split("I16,K16,W16,Y16", ",")
    
    Pos = Application.Match(Target.Address(0, 0), strAry(0), 0)
    
    If IsNumeric(Pos) Then
        Pos = Pos * 10 + 1 '1桁目は1。strAry(1)が転記先
    Else
        Pos = Application.Match(Target.Address(0, 0), strAry(1), 0)
        If IsNumeric(Pos) Then
            Pos = Pos * 10 '1桁目は0。strAry(0)が転記先
        Else
            Exit Sub
        End If
    End If
    
    Application.EnableEvents = False
        Range(strAry(Pos Mod 10)(Pos \ 10 - 1)) = Target.Value
    Application.EnableEvents = True
End Sub

緑の太文字

茶色の太文字

赤の太文字

青の太文字

[196174] Re[10]: 2つのセルに入力して反映

(2024/04/25(15:48))
□U R L/

ソースは、こちらです。。

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim strAry(0 To 1)
    Dim Pos
    
    strAry(0) = Array("T7", "X7", "AB7", "AF7", "AJ7", "AN7", "AR7", "AV7", "AB9", "AF9", "AJ9", "AN9", "AR9", "AV9", "AJ11", "AN11", "AR11", "AV11", "AR13", "AV13")
    strAry(1) = Array("T24", "X24", "AZ24", "BD24", "AZ30", "BD30", "T28", "X28", "T30", "X30", "AZ26", "BD26", "AZ32", "BD32", "T26", "X26", "AZ28", "BD28", "T32", "X32")
    
    Pos = Application.Match(Target.Address(0, 0), strAry(0), 0)
    
    
        
    If IsNumeric(Pos) Then
        Pos = Pos * 10 + 1 '1桁目は1。strAry(1)が転記先
    Else
        Pos = Application.Match(Target.Address(0, 0), strAry(1), 0)
        If IsError(Pos) Then
            Exit Sub
        Else
            Pos = Pos * 10 '1桁目は0。strAry(0)が転記先
        End If
    End If
    
    Application.EnableEvents = False
        Range(strAry(Pos Mod 10)(Pos \ 10 - 1)) = Target.Value
    Application.EnableEvents = True
End Sub

緑の太文字

茶色の太文字

赤の太文字

青の太文字

[196175] Re[11]: 2つのセルに入力して反映

(2024/04/25(16:42))
□U R L/

＞下記のソースにした場合
＞セルを空白（数値をクリア）にしても、反映されません、、

そんなハズないと思うのですが、、
１セルずつ入力しないと反応しないと言う話なら、
そういう仕様にしてありますので、何らかの追加処置が必要になります。

それとも、それ以前に何かトラブった後に起きているなら
こいつで目を覚まさせてください。

Sub wakeUp()
    Application.EnableEvents = True
End Sub


この記事にはVBAのコードが含まれています。

緑の太文字→注釈
茶色の太文字→条件分岐
赤の太文字→ループ
青の太文字→その他

[196176] Re[10]: 2つのセルに入力して反映

(2024/04/25(17:02))
□U R L/

T7セルにDeleteでセルの値をクリアしてもT24の値はそのままで変わりません、

ご指摘頂いた
Sub wakeUp()
    Application.EnableEvents = True
End Sub
これも追加してみましたが、変化ありません。

数字を入れた時だけ反映されます。

緑の太文字

茶色の太文字

赤の太文字

青の太文字

[196177] Re[11]: 2つのセルに入力して反映

(2024/04/25(17:38))
□U R L/

＞T7セルにDeleteでセルの値をクリアしてもT24の値はそのままで変わりません
こちらでは再現しません。
以下のMsgbox文を挿入してから、T7をクリアしてみてください。

　＞End If
    MsgBox Range(strAry(Pos Mod 10)(Pos \ 10 - 1)).Address & " " & IIf(IsEmpty(Target.Value), "クリア", "値" & Target.Value)
  ＞Application.EnableEvents = False

どんなメッセージが出ましたか？
こちらでは「$T$24 クリア」となりますが・・


この記事にはVBAのコードが含まれています。

緑の太文字→注釈
茶色の太文字→条件分岐
赤の太文字→ループ
青の太文字→その他

[196178] Re[11]: 2つのセルに入力して反映

(2024/04/25(23:34))
□U R L/

[196174]のソースにて、、

End Ifの後にご指摘の一文を追加したら　数値をT7に入力すると　$T$24　値　数値
とメッセージボックスが表示されます！！（OK)

しかし、

空白にしたところ、
 If IsNumeric(Pos) Then
            Pos = Pos * 10 '1桁目は0。strAry(0)が転記先
        Else
            Exit Sub
        End If

の部分で、Exit Subにとび、メッセージ表示されません。

試しにF8で一文ずつみると、Pos＝のところで、エラー2042となり、
Exit Subで処理されています。

試しに、Pos＝の前にメッセージボックス表示の一文を入れてみましたが
型が一致しませんのエラーがでます。

緑の太文字

茶色の太文字

赤の太文字

青の太文字

[196179] Re[12]: 2つのセルに入力して反映

(2024/04/26(08:23))
□U R L/

微妙にコードが違うような気がします。

以下のコードで全体を上書きして、トライしてみてください。

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim strAry(0 To 1)
    Dim Pos
    
    strAry(0) = Split("T7,X7,AB7,AF7,AJ7,AN7,AR7,AV7,AB9,AF9,AJ9,AN9,AR9,AV9,AJ11,AN11,AR11,AV11,AR13,AV13", ",")
    strAry(1) = Split("T24,X24,AZ24,BD24,AZ30,BD30,T28,X28,T30,X30,AZ26,BD26,AZ32,BD32,T26,X26,AZ28,BD28,T32,X32", ",")
    
    Pos = Application.Match(Target.Address(0, 0), strAry(0), 0)
        
    If IsNumeric(Pos) Then
        Pos = Pos * 10 + 1 '1桁目は1。strAry(1)が転記先
    Else
        Pos = Application.Match(Target.Address(0, 0), strAry(1), 0)
        If IsError(Pos) Then
            Exit Sub
        Else
            Pos = Pos * 10 '1桁目は0。strAry(0)が転記先
        End If
    End If
    
    Application.EnableEvents = False
        Range(strAry(Pos Mod 10)(Pos \ 10 - 1)) = Target.Value
    Application.EnableEvents = True
End Sub

上のコードで正常動作することを確認してください。

その後、そちら独自の変更(もしあれば）を施すと旨く行かなくなるなら、
どう変更したのか教えてください。


この記事にはVBAのコードが含まれています。

緑の太文字→注釈
茶色の太文字→条件分岐
赤の太文字→ループ
青の太文字→その他

[196180] Re[13]: 2つのセルに入力して反映

(2024/04/26(08:40))
□U R L/

＞Exit Subにとび、メッセージ表示されません。

コードの先頭に

    MsgBox Target.Address(0, 0)

としてみたら原因が判明するかも。


この記事にはVBAのコードが含まれています。

緑の太文字→注釈
茶色の太文字→条件分岐
赤の太文字→ループ
青の太文字→その他

[196181] Re[13]: 2つのセルに入力して反映

(2024/04/26(09:25))
□U R L/

半平太さま
196179のソースに書き換えました

数値の時は対のセルに値が変更されますが（OK)

空白にした場合は

Pos = Application.Match(Target.Address(0, 0), strAry(0), 0)
で、エラー2042となり
 Exit Sub
となり、そのセルだけ空白で対のセルには数値が残ったままになります。

緑の太文字

茶色の太文字

赤の太文字

青の太文字

[196182] Re[14]: 2つのセルに入力して反映

(2024/04/26(09:54))
□U R L/

＞        If IsError(Pos) Then
            MsgBox Target.Address(0, 0) 'ここに一文挿入して,"T7"と出るか確認してください。
＞            Exit Sub


この記事にはVBAのコードが含まれています。

緑の太文字→注釈
茶色の太文字→条件分岐
赤の太文字→ループ
青の太文字→その他


[196183] Re[15]: 2つのセルに入力して反映- ■記事引用/メール受信=OFF■ □投稿者/ むみ -(2024/04/26(11:20)) □U R L/ 2セル結合してますので、 T7:U8 と表示されました！！

[196184] Re[16]: 2つのセルに入力して反映

(2024/04/26(12:05))
□U R L/

なるほどです。
私も知らなかったです。ありがとうございます。
※結合セルだと、値入力では単セル、クリア操作では複数セルが返っていますね。

なら、冒頭で強制的にワンセルにする案↓

＞  Dim Pos
    Set Target = Target.Cells(1, 1)　’ここで左上の１セルに限定する


この記事にはVBAのコードが含まれています。

緑の太文字→注釈
茶色の太文字→条件分岐
赤の太文字→ループ
青の太文字→その他

[196185] Re[17]: 2つのセルに入力して反映

(2024/04/26(13:17))
□U R L/

[196186] Re[18]: 2つのセルに入力して反映

(2024/04/26(14:29))
□U R L/

＞Range(strAry(Pos Mod 10)(Pos \ 10 - 1)) = Target.Value
＞この一文の意味が理解できません
確かに分かりにくいですよねー。

意図するところは簡単で、
(1)変更したセルは  strAry(0)内のアドレスなのか strAry(1)内なのか。　
(2)配列の何番目に在ったのか。
それが分かれば、自動変更が可能である、と言う事になります。

さて
Pos = Application.Match(Target.Address(0, 0), strAry(0), 0)
Pos = Application.Match(Target.Address(0, 0), strAry(1), 0)

上記２つのステートメントにより、何番目かが判明し、
どっちの配列に在ったのかは strAry(0)か strAry(1)の違いで分かる。

そこで
strAry(0)内に在った場合、Posを10倍して、1を足す
 Pos = Pos * 10 + 1 '1桁目は1。strAry(1)が転記先

strAry(1)内に在った場合は、Posを10倍して、何も足さない。
　Pos = Pos * 10 '1桁目は0。strAry(0)が転記先

そんな加工をPosに施しておくと
　(Pos Mod 10）　 →　Posを10で割った余りが、自動変更すべき相手方の配列番号を示し、
　(Pos \ 10 - 1)　→　Posを10で割った商が、配列内の添え字になる
                      (ただし、配列の添え字は0スタートなので、1を差し引く)

以上で必要な数値が揃ったので
自動変更すべきセルを特定して、Targetの値を代入する。

Range(strAry(相手方の配列番号)(配列内添え字)) = Target.Value

例えば、T7に変更があれば
　Range(strAry(1) (1-1)) = Target.Value

[196187] Re[19]: 2つのセルに入力して反映

(2024/04/26(15:11))
□U R L/

このトピック内容の全ページ数 / [0]

このトピックに書きこむ

Name /

E-Mail /

└>このツリーのレス記事をメールで受信しますか? YES/ NO/

Title /

URL /

Comment/ 通常モード->　図表モード-> (←の場合適当に改行を入れて下さい)
タグが使用できます。例 ⇒ <font color="blue">文字</font>

解決保留迷宮入 Help! ←※回答者専用
解決したらチェック保留(コードテスト中など・・) 解決不可orレスが全く付かなくてほかのサイトに行くときなど・・

削除キー /
(半角8文字以内)　

- Child Forum -
Edit:ゆう-Ｇ