『フィルターかけたセルのコピー』(にわか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 >
A B C D E 1 不明な番号1 不明な番号2 氏名 謎の商品名 謎の商品名2
2 5 6 花子 リンゴ1 バナナ1
3 8 9 一郎 メロン1
4 19 11 拓哉 バナナ2
(*^^*)v
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 D 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
リンゴ01バナナ15よだれどり02
たまご150にしん10
なんかは有るのでしょうか。。。^^;
全てのあり得るパターンを教えて下さいますでしょうか。m(__)m
(隠居Z) 2024/04/25(木) 08:23:34
A B C E
ということでD列がないですが。そのぉふつうここ無ければ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
ああ、5行目から書き出すなら、Dim pos As Longのあとで pos=4 としてください。 フィルタがかかっているところを抽出するのは、 SpecailCells(xlCellTypeVisible)を使って絞り込み、 それらを For each して各行ごとに処理してももちろんOKです。 (xyz) 2024/04/25(木) 08:56:57
パターンは、
リンゴ1バナナ3
メロン1バナナ2
リンゴ1
バナナ1
メロン1
果物の後は、半角の数字で、1〜9の値をとります
リンゴ、バナナ、メロン以外は、ないです
後は、3つの果物の組み合わせはないです
あと、D列は、関係ないので、省きました
(にわかVBA者) 2024/04/25(木) 10:09:06
xyzさんのコード
一か所だけ D を E に替えれば。。。完成!!!だと思います
もうすこしすれば、きっと、返信くださいますよ。(*^^*)
正規表現。。。凄いですね
勉強したいと思っています。m(_ _)m
(隠居Z) 2024/04/25(木) 10:38:18
知らんふりはせずに後片付けくらいはやったらどう?
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 と4つのセルに分けるべきです。他のセルも同じです。 そうすればもっと標準的な方法でコード化ができるでしょう。 その方向で再トライすることをお薦めします。
2.これもシート上に保持すべき情報です。 リンゴであれば、紙 バナナであれば、ポリ袋 メロンであれば、箱 (コードにだけでてくるのは避けるべきです。書いた本人が言うので間違いない。) 以上です。 (xyz) 2024/04/25(木) 16:17:42
xyzさんが、書いたコードで、
A〜C列 →A〜D.I列、
E列食べ物→J列食べ物
に変更したコードを教えてください
よろしくお願いします
(にわかVBA者) 2024/04/26(金) 10:37:09
> xyzさんが、書いたコードで、 > A〜C列 →A〜D.I列、 > E列食べ物→J列食べ物 意味がわかりませんので、私には無理です。
そちらで修正してみたものを示してください。 そうすれば皆さんからもコメントがつくものと思います。失礼します。 (xyz) 2024/04/26(金) 13:48:53
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
pos=5
かな?
違ってたら済みません^^;
m(__)m
(隠居Z) 2024/04/27(土) 10:06:13
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 pos = 6 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, "J") 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") = ws1.Cells(p, "D") ws2.Cells(pos, "G") = ws1.Cells(p, "I") ws2.Cells(pos, "I") = num & itm1 ws2.Cells(pos, "J") = 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") = ws1.Cells(p, "D") ws2.Cells(pos, "G") = ws1.Cells(p, "I") ws2.Cells(pos, "I") = num & itm2 ws2.Cells(pos, "J") = dic(itm2) Next End If End Function 上記プログラムで ws1のA,B列に値がなく、C,D,I,J列に値がある場合、処理がすすみません この修正を教えてください。よろしくお願いします
(にわかVBA) 2024/05/08(水) 09:58:13
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.