HOME > Q&A > Excel （VBA）

Excel （VBA）
Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 11 Pro : Excel 2013)
住所録の連名データを付け加えたい
投稿日時: 26/01/25 13:48:21
投稿者: T_hama

こんにちは。
連名データとしての扱い⇒追加行
としてのマクロを、お尋ねします。
 
[A列]No.
[B列]ﾌﾘｶﾞﾅ
[C列]氏名
[D列]連名１
[E列]連名２
[F列]連名３
[G列]連名４
[H列]〒
[I列]住所１
[J列]住所２
[K列]会社名
 
というデータです。シートがあります
 
ここで
連名のある［行］を取り出し、データを再編したい。もしくは、
新たな追加データとして出力したい。です。
 
※
[C列]氏名
は、「姓」＋全角スペース ＋「名」
です。
 
 
●[D列]連名１
は、
[A列]No.
[B列]ﾌﾘｶﾞﾅ
[C列] の「姓」＋ [D列]連名１
（これをL列にもってくるとか・・）
[H列]〒
[I列]住所１
[J列]住所２
[K列]会社名
は、同様。（[H列]～[K列]はコピー）
 
 
 
●[E列]連名２
であれば
[C列] の「姓」＋ [E列]連名２
を［L列］に。
 
 
●[F列]連名３
は、［L列］⇒[C列] の「姓」＋ [F列]連名３
[H列]～[K列]はコピー
 
 
●[G列]連名４
は、［L列］⇒[C列] の「姓」＋ [G列]連名４
[H列]～[K列]はコピー
 
などなど。どうにか、簡便に、データを変更したいのですが、
どういうマクロで可能なのか、
厚かましいのは、承知していますが、お伺いします。
何卒よろしくお願いします。
 
回答
投稿日時: 26/01/25 19:17:46
投稿者: simple

こんばんは。
 

    A   B         C          D      E      F      G      H        I      J       K
1   No. ﾌﾘｶﾞﾅ     氏名       連名１ 連名２ 連名３ 連名４ 〒       住所１ 住所２  会社名
2   100 ﾔﾏﾀﾞ　ﾀﾛｳ 山田　太郎 一郎   二郎                 100-0001 XXX    YYY     ZZZ
というデータがあったとき、どのようなデータに変更するのか、明示して下さい。
 
（回答者には、その住所録をどのように使っているのか不明ですから、
どのようにするとよいかまでは回答できません。
それは質問者さんがお考えいただくことです。）
 
同じ住所録のなかに新しい行を追加するとした場合、
色々なやりかたがあると思いますが、例えば、こんな方針が考えられます。
・連名があるかどうかを行ごとに判断し、
・連名があればその下にその連名の個数だけ行を挿入し、
・そこにいったん現在のデータを仮にコピーします。
・さらに必要な修正、削除処理を行います。氏名の修正などです。
 
なお、一人一人にばらした場合、どれがグループに属するかを判定する項目が必要かもしれませんね。
(Noという列がどういう使い方か不明なので、それをどう扱うかも、そちらで決める必要もあるでしょう。）
 
なお、その処理は、最後の行から上に遡って処理すると良いでしょう。
・上からやっていくと、挿入処理によって作業対象の行番号が変化してしまって、扱いが複雑になります。
・下から遡って処理していけば、挿入処理による影響が避けられます。
   (普通の For k= "最終行の行番号" To 2 Step -1 とすればよいです。）

投稿日時: 26/01/25 21:09:58
投稿者: T_hama

simpleさま
ご返答をありがとうございます。よろしくお願いします。
 
 
    A B C D E F G H I J K
1 No. ﾌﾘｶﾞﾅ 氏名 連名１ 連名２ 連名３ 連名４ 〒 住所１ 住所２ 会社名
2 100 ﾔﾏﾀﾞ　ﾀﾛｳ 山田　太郎 一郎 二郎 100-0001 XXX YYY ZZZ
 
 
データを以下のように、出来ましたら、
完璧です。
 
A B C D E F G H I J K L
No. ﾌﾘｶﾞﾅ 氏名 連名１ 連名２ 連名３ 連名４ 〒 住所１ 住所２ 会社名 宛先
100 ﾔﾏﾀﾞ　ﾀﾛｳ 山田　太郎 一郎 二郎 100-0001 XXX YYY ZZZ 山田　太郎
100 ﾔﾏﾀﾞ　ﾀﾛｳ 山田　太郎 一郎 二郎 100-0001 XXX YYY ZZZ 山田　一郎
100 ﾔﾏﾀﾞ　ﾀﾛｳ 山田　太郎 一郎 二郎 100-0001 XXX YYY ZZZ 山田　二郎
101 ｽｽﾞｷ　ﾊﾅｺ 鈴木　花子 １子 ２子 ３子 ４子 777-7777 aaa ccc ggg 鈴木　花子
101 ｽｽﾞｷ　ﾊﾅｺ 鈴木　花子 １子 ２子 ３子 ４子 777-7777 aaa ccc ggg 鈴木　１子
101 ｽｽﾞｷ　ﾊﾅｺ 鈴木　花子 １子 ２子 ３子 ４子 777-7777 aaa ccc ggg 鈴木　２子
101 ｽｽﾞｷ　ﾊﾅｺ 鈴木　花子 １子 ２子 ３子 ４子 777-7777 aaa ccc ggg 鈴木　３子
101 ｽｽﾞｷ　ﾊﾅｺ 鈴木　花子 １子 ２子 ３子 ４子 777-7777 aaa ccc ggg 鈴木　４子
 
 
＞・連名があるかどうかを行ごとに判断し、
連名は全ての行にあります（連名１～連名４）
氏名のみの行は、別途のデータにしました。(後で、付け加えます)
 
※詳細は、
連名１：送付先2枚
連名２：送付先3枚としたい
連名３：送付先4枚としたい
連名４：送付先5枚としたい
です。
 
 
＞・連名があればその下にその連名の個数だけ行を挿入し、
＞・そこにいったん現在のデータを仮にコピーします。
その通りでございます。
 
＞・さらに必要な修正、削除処理を行います。氏名の修正などです。
宛名としての[L列]を設けたいので、
氏名の修正は不要と思っています。
 
 
何卒お教え下さい。ご教授下さい。
●スイマセン。厚かましくて、恐縮です。申し訳ありません。

投稿日時: 26/01/26 09:02:28
投稿者: T_hama

おはようございます。
 

No.	ﾌﾘｶﾞﾅ	氏名	連名１	連名２	連名３	連名４	〒	住所１	住所２	会社名
1	ﾔﾏﾀﾞ ﾀﾛｳ	山田　太郎	一郎	二郎			100-0001	XXX	YYY	ZZZ
2	ｽｽﾞｷ ﾊﾅｺ	鈴木　花子	１子	２子	３子	４子	777-7777	aaa	ccc	ggg

 
が元セルとして、其の横へ
 
M	N	O	P	Q	R	S	T	U	V	W	X
No.	ﾌﾘｶﾞﾅ	氏名	連名１	連名２	連名３	連名４	〒	住所１	住所２	会社名	宛名
100	ﾔﾏﾀﾞ ﾀﾛｳ	山田　太郎	一郎	二郎			100-0001	XXX	YYY	ZZZ	山田　太郎
100	ﾔﾏﾀﾞ ﾀﾛｳ	山田　太郎	一郎	二郎			100-0001	XXX	YYY	ZZZ	山田　一郎
100	ﾔﾏﾀﾞ ﾀﾛｳ	山田　太郎	一郎	二郎			100-0001	XXX	YYY	ZZZ	山田　二郎
101	ｽｽﾞｷ ﾊﾅｺ	鈴木　花子	１子	２子	３子	４子	777-7777	aaa	ccc	ggg	鈴木　花子
101	ｽｽﾞｷ ﾊﾅｺ	鈴木　花子	１子	２子	３子	４子	777-7777	aaa	ccc	ggg	鈴木　１子
101	ｽｽﾞｷ ﾊﾅｺ	鈴木　花子	１子	２子	３子	４子	777-7777	aaa	ccc	ggg	鈴木　２子
101	ｽｽﾞｷ ﾊﾅｺ	鈴木　花子	１子	２子	３子	４子	777-7777	aaa	ccc	ggg	鈴木　３子
101	ｽｽﾞｷ ﾊﾅｺ	鈴木　花子	１子	２子	３子	４子	777-7777	aaa	ccc	ggg	鈴木　４子

 
と言う風に、置きたいのですが、マクロが作れません。
何卒よろしくお願いします。
回答
投稿日時: 26/01/26 09:28:17
投稿者: simple 

Sub test()
    Dim k As Long, n As Long
    Dim j As Long, pos As Long

    For k = 3 To 2 Step -1
        n = Application.CountA(Cells(k, "D").Resize(1, 4))  '連名の個数
        Cells(k, "A").Resize(1, 12).Copy
        Cells(k + 1, "A").Resize(n, 12).Insert Shift:=xlDown

        '宛先の追加
        Cells(k, "L") = Cells(k, "C")       '元データへの追加
        For j = 1 To n                      '増幅データへの追加
            pos = InStr(Cells(k, "C"), "　")
            Cells(k + j, "L") = Left(Cells(k, "C"), pos) & Cells(k + j, 3 + j)
        Next
    Next
    Application.CutCopyMode = False
End Sub
連名ありのデータをそのままの列で修正するものです。新たな仕様変更はそちらで対応して下さい。
作成にあたっての考え方も示したのですから、少しはご自分でトライする姿勢くらい見せて欲しかった。
（作成依頼は禁止事項に挙げられています。）
 
T_hamaさんは、2012年10月にコードを作成されたうえで質問されています。(私の記録によるとw）
今後は、それと同じように、トライしたうえで質問して下さい。
作成依頼なら生成AIを使って下さい。

投稿日時: 26/01/26 10:47:10
投稿者: T_hama

simpleさま
ご返答をありがとうございます。
 
Sub test()
を実行しました。連名４まである行(Row)について、実行されました。
 
連名３まである行(Row)、
連名２迄ある行(Row)、
連名1まである行(Row)
以上の行は、何も変化がありませんでした。
 
Sub renmei3()
    Dim k As Long, n As Long
    Dim j As Long, pos As Long
 
    For k = 2 To 1 Step -1
        n = Application.CountA(Cells(k, "D").Resize(1, 3)) '連名の個数
        Cells(k, "A").Resize(1, 12).Copy
        Cells(k + 1, "A").Resize(n, 12).Insert Shift:=xlDown
 
        '宛先の追加
        Cells(k, "L") = Cells(k, "C") '元データへの追加
        For j = 1 To n '増幅データへの追加
            pos = InStr(Cells(k, "C"), "　")
            Cells(k + j, "L") = Left(Cells(k, "C"), pos) & Cells(k + j, 3 + j)
        Next
    Next
    Application.CutCopyMode = False
End Sub
 
として、連名３まである行を処理しようとしましたが、
上手く行きません。
（ For k = 2 To 2 Step -1
も試しました。NGでした）
 
 
何もかも頼ろうとして申し訳ありませんでした。
反省しています。
 
追伸：（いい訳になります・・・）
私、2015年に大怪我をして頭を手術して以降、どうにも、
回転が鈍りまして、Excelは殆ど使ってないので、
何もかもが、手間取ってしまい・・・失礼しました。
 
言い訳をさせて頂き申し訳ありませんでした。
回答
投稿日時: 26/01/26 11:10:01
投稿者: simple

 1行目は見出し、2行目以下にデータがあり、最終行までが対象範囲なら 

 For k = Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
としてください。
投稿日時: 26/01/26 12:31:00
投稿者: T_hama

simple さんの引用:
1行目は見出し、2行目以下にデータがあり、最終行までが対象範囲なら 
 For k = Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
としてください。

 
お教えの通りにSub test()を
Sub test2()として、実行しました。
 
完璧でした！希望通りになりました。
マクロの記述を見返して、
とても到達できる域ではございません。
 
この様なマクロが、出来得るには
数千回以上の試行錯誤があって、到達為されたのだと・・・
 
本当に、上澄を頂くようで、恐縮です。今後は、
丸投げしないように努めて参ります。お礼申し上げます。
誠にありがとうございました。本当に助かりました。
拝礼させて頂きます。感謝申し上げます。
 
 
Sub test2()
    Dim k As Long, n As Long
    Dim j As Long, pos As Long

    For k = Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
        n = Application.CountA(Cells(k, "D").Resize(1, 4))  '連名の個数
        Cells(k, "A").Resize(1, 12).Copy
        Cells(k + 1, "A").Resize(n, 12).Insert Shift:=xlDown

        '宛先の追加
        Cells(k, "L") = Cells(k, "C")       '元データへの追加
        For j = 1 To n                      '増幅データへの追加
            pos = InStr(Cells(k, "C"), "　")
            Cells(k + j, "L") = Left(Cells(k, "C"), pos) & Cells(k + j, 3 + j)
        Next
    Next
    Application.CutCopyMode = False
End Sub