エクセルの学校：エクセル質問ボード[[20240424150644]]

エクセル	の学校
8.一覧	9.HOME
1.Top	2.Last

[[20240424150644]]

[ 初めての方へ | 一覧(最新更新順) |

| | 全文検索 | 過去ログ | エクセルの学校HOME ]

『フィルターかけたセルのコピー』（にわかVBA者）

以下は、フィルターかけたデータで例

  5     6    花子　  リンゴ1バナナ1   
  8     9    一郎　　メロン1 
　19   11     拓哉　　バナナ2

上記のデータを以下のように、別のExcelファイルにコピー

 5  6   花子　1リンゴ　紙
 5  6   花子　2バナナ　ポリ袋
 8  9   一郎　1メロン  箱
 19 11  拓哉  1バナナ  ポリ袋
 19 11  拓哉　2バナナ　ポリ袋

リンゴであれば、紙バナナであれば、ポリ袋　メロンであれば、箱

リンゴ1バナナ1であれば、 1リンゴ 2 バナナメロン1バナナ2であれば 1メロン 2バナナ 3バナナ　番号を果物の頭に入れる

マクロを教えてくださいよろしくお願いします

＜使用 Excel：unknown、使用 OS：unknown ＞

こんにちわ～。。。＾＾どのセルにどの情報が入っているのかご説明された方がよろしいかと。^^; 例　↓

        Ａ　     　    　Ｂ　　　Ｃ　　　  Ｄ        Ｅ
 1     不明な番号1　不明な番号2　氏名　謎の商品名   謎の商品名2

 2         5            6        花子    リンゴ1       バナナ1

 3         8            9        一郎  　メロン1

 4      　19           11        拓哉  　バナナ2

(*^^*)ｖ m(__)m （隠居Z） 2024/04/24(水) 16:04:31

すみません… フィルターをかけたデータは

    A       B     C             E
2  番号1　　番号2 　名前　　　     食べ物
16  　 5      6   花子　  リンゴ1バナナ1   
22    8       9   一郎　　      メロン1 
34    19     11   拓哉　　      バナナ2

コピー後は

     C  Ｄ    E       F    G 
5    5  6   花子　1リンゴ　  紙
6    5  6   花子　2バナナ　ポリ袋
7    8  9   一郎　1メロン    箱
8   19 11   拓哉  1バナナ  ポリ袋
9   19 11  拓哉　 2バナナ　ポリ袋

わかりにくければ、教えてくださいよろしくお願いします（にわかVBA者） 2024/04/24(水) 17:58:38

あれ～。。。おや。。。もうよいのですか。↑　お終いで。。。(￣▽￣) (*^ ^*)。。。。。m(_ _)m （隠居Z） 2024/04/24(水) 20:50:16

よろしくお願いしますm(_ _)m （にわかVBA者） 2024/04/25(木) 07:10:04

おはようございます。フィルターをかけたデータの食べ物ですが

リンゴ01バナナ15よだれどり02

たまご150にしん10

なんかは有るのでしょうか。。。＾＾；全てのあり得るパターンを教えて下さいますでしょうか。m(__)m

（隠居Z） 2024/04/25(木) 08:23:34

追記フィルターをかけたデータ

 A　B　C　E

ということでＤ列がないですが。そのぉふつうここ無ければE列はフイルターかからないと思うのですが、有るけど関係無いので省いたとかでせうか。。。。。＾＾；おしえてくださぁ～い。(*^^*) m(__)m （隠居Z） 2024/04/25(木) 08:36:45

 横からすみません。
 こんな風にしてみたらどうでしょうか。

 Option Explicit

 Dim ws1 As Worksheet, ws2 As Worksheet
 Dim dic       As Object
 Dim re        As Object

 Sub main()
     Set ws1 = Worksheets("Sheet1")  '■適宜修正
     Set ws2 = Worksheets("Sheet2")  '■適宜修正

     Set dic = CreateObject("Scripting.Dictionary")
     dic("リンゴ") = "紙"
     dic("バナナ") = "ポリ袋"
     dic("メロン") = "箱"

     Set re = CreateObject("VBScript.RegExp")        '正規表現を利用
     re.Pattern = "(?:(\D+)(\d+))(?:(\D+)(\d+))?"

     Dim k     As Long
     Dim pos   As Long
     For k = 3 To ws1.Cells(Rows.Count, "A").End(xlUp).Row
         If ws1.Rows(k).Hidden = False Then
             Call sub1(k, pos)
         End If
     Next
 End Sub

 Function sub1(p As Long, pos As Long)
     Dim s$
     Dim matches As Object
     Dim m     As Object
     Dim itm1$, itm2$
     Dim cnt1&, cnt2&
     Dim num&, k&

     s = ws1.Cells(p, "D")
     Set matches = re.Execute(s)
     Set m = matches(0)
     itm1 = m.SubMatches(0)
     cnt1 = m.SubMatches(1)
     num = 0
     For k = 1 To cnt1
         num = num + 1
         pos = pos + 1
         ws2.Cells(pos, "C") = ws1.Cells(p, "A")
         ws2.Cells(pos, "D") = ws1.Cells(p, "B")
         ws2.Cells(pos, "E") = ws1.Cells(p, "C")
         ws2.Cells(pos, "F") = num & itm1
         ws2.Cells(pos, "G") = dic(itm1)
     Next

     itm2 = m.SubMatches(2)
     cnt2 = m.SubMatches(3)
     If itm2 <> "" Then
         For k = 1 To cnt2
             num = num + 1
             pos = pos + 1
             ws2.Cells(pos, "C") = ws1.Cells(p, "A")
             ws2.Cells(pos, "D") = ws1.Cells(p, "B")
             ws2.Cells(pos, "E") = ws1.Cells(p, "C")
             ws2.Cells(pos, "F") = num & itm2
             ws2.Cells(pos, "G") = dic(itm2)
         Next
     End If
 End Function

（xyz） 2024/04/25(木) 08:50:38

 ああ、５行目から書き出すなら、Dim pos As Longのあとで pos=4 としてください。
 フィルタがかかっているところを抽出するのは、
 SpecailCells(xlCellTypeVisible)を使って絞り込み、
 それらを For each して各行ごとに処理してももちろんOKです。
（xyz） 2024/04/25(木) 08:56:57

隠居Zさん、返信ありがとうござます！

パターンは、リンゴ1バナナ3 メロン1バナナ2 リンゴ1 バナナ1 メロン1

果物の後は、半角の数字で、1〜9の値をとりますリンゴ、バナナ、メロン以外は、ないです後は、3つの果物の組み合わせはないです

あと、Ｄ列は、関係ないので、省きました

（にわかVBA者） 2024/04/25(木) 10:09:06

↑　と　いう　事でしたら。

　xyzさんのコード一か所だけ　D　を　E　に替えれば。。。完成！！！だと思いますもうすこしすれば、きっと、返信くださいますよ。(*^^*) 正規表現。。。凄いですね勉強したいと思っています。m(_ _)m （隠居Z） 2024/04/25(木) 10:38:18

xyzさ、ああさん、隠居Zさん、みなさんありがとうござました！試してみます！（にわかVBA者） 2024/04/25(木) 11:01:49

 知らんふりはせずに後片付けくらいはやったらどう？

https://excelfactory.net/excelboard/excelvba/excel.cgi?mode=all&namber=196169&rev=0 （マルチポスト） 2024/04/25(木) 13:57:19

 隠居Zさんのご指摘のとおりかと思います。ありがとうございます。

 コードを示してから申し上げることではないですが、念のためコメントしておきます。
 Excelの使用方法の工夫が必要です。
 1."リンゴ1バナナ1" などと一つのセルにいくつもの情報を詰め込むのは感心しません。
   入力はメモ帳に書く感覚で,得した気持ちかもしれませんが、将棋で言えば"悪手"です。
   リンゴ  1  バナナ  1   と４つのセルに分けるべきです。他のセルも同じです。
   そうすればもっと標準的な方法でコード化ができるでしょう。
   その方向で再トライすることをお薦めします。

 2.これもシート上に保持すべき情報です。
     リンゴであれば、紙
     バナナであれば、ポリ袋
     メロンであれば、箱
  （コードにだけでてくるのは避けるべきです。書いた本人が言うので間違いない。）    
 以上です。 
（xyz） 2024/04/25(木) 16:17:42

コピー元のbookファイルが、長年、一つのセルに書きこまれているので、なかなか、変更できません… すみません…

xyzさんが、書いたコードで、 A〜C列　→A〜Ｄ.I列、

E列食べ物→Ｊ列食べ物

に変更したコードを教えてくださいよろしくお願いします

（にわかVBA者） 2024/04/26(金) 10:37:09

 > xyzさんが、書いたコードで、
 > A〜C列　→A〜Ｄ.I列、
 > E列食べ物→Ｊ列食べ物
 意味がわかりませんので、私には無理です。

 そちらで修正してみたものを示してください。
 そうすれば皆さんからもコメントがつくものと思います。失礼します。
（xyz） 2024/04/26(金) 13:48:53

上記の件は解決しました。追加で、コピー先のシートの開始位置をC6から、初めるコードを教えてください。

Option Explicit

 Dim ws1 As Worksheet, ws2 As Worksheet
 Dim dic       As Object
 Dim re        As Object
 Sub main()
     Set ws1 = Worksheets("Sheet1")  '■適宜修正
     Set ws2 = Worksheets("Sheet2")  '■適宜修正
     Set dic = CreateObject("Scripting.Dictionary")
     dic("リンゴ") = "紙"
     dic("バナナ") = "ポリ袋"
     dic("メロン") = "箱"
     Set re = CreateObject("VBScript.RegExp")        '正規表現を利用
     re.Pattern = "(?:(\D+)(\d+))(?:(\D+)(\d+))?"
     Dim k     As Long
     Dim pos   As Long
     For k = 3 To ws1.Cells(Rows.Count, "A").End(xlUp).Row
         If ws1.Rows(k).Hidden = False Then
             Call sub1(k, pos)
         End If
     Next
 End Sub
 Function sub1(p As Long, pos As Long)
     Dim s$
     Dim matches As Object
     Dim m     As Object
     Dim itm1$, itm2$
     Dim cnt1&, cnt2&
     Dim num&, k&
     s = ws1.Cells(p, "D")
     Set matches = re.Execute(s)
     Set m = matches(0)
     itm1 = m.SubMatches(0)
     cnt1 = m.SubMatches(1)
     num = 0
     For k = 1 To cnt1
         num = num + 1
         pos = pos + 1
         ws2.Cells(pos, "C") = ws1.Cells(p, "A")
         ws2.Cells(pos, "D") = ws1.Cells(p, "B")
         ws2.Cells(pos, "E") = ws1.Cells(p, "C")
         ws2.Cells(pos, "F") = num & itm1
         ws2.Cells(pos, "G") = dic(itm1)
     Next
     itm2 = m.SubMatches(2)
     cnt2 = m.SubMatches(3)
     If itm2 <> "" Then
         For k = 1 To cnt2
             num = num + 1
             pos = pos + 1
             ws2.Cells(pos, "C") = ws1.Cells(p, "A")
             ws2.Cells(pos, "D") = ws1.Cells(p, "B")
             ws2.Cells(pos, "E") = ws1.Cells(p, "C")
             ws2.Cells(pos, "F") = num & itm2
             ws2.Cells(pos, "G") = dic(itm2)
         Next
     End If
 End Function
（にわかVBA者） 2024/04/26(金) 15:51:46

割り込み失礼致します。<< _ _ >> たしかどこかで、xyz　さんもご案内だったように思いますが mainでループに入る前に

pos=5

かな？違ってたら済みません＾＾；

m(__)m

（隠居Z） 2024/04/27(土) 10:06:13

[ 一覧(最新更新順) |

]

キーボードヒント：[Home]または[Fn+Home]キーで一番上へ戻ります