Results of 1 - 1 of about 8930 for リスト (0.006 sec.)
- [[20211014143431]]
- #score: 2746
- @digest: d9ff9b4cbab9956bf98d5dd43b30bae8
- @id: 89297
- @mdate: 2021-10-19T08:36:36Z
- @size: 23484
- @type: text/plain
- #keywords: 物情 (140107), sfilename (129194), 斗| (103895), 北斗 (98398), 生物 (96269), rlsty (88570), 区| (87916), 覧. (80321), ゴ| (76643), rsltx (72681), 玉| (68725), 紅玉 (66833), ト抽 (53719), キ| (40870), 報. (36639), 地区 (36075), 表範 (28579), 覧= (26257), 覧as (25838), 囲. (23243), タ¥" (21846), result (21273), 出( (21091), ンゴ (15986), ル1 (15177), 限ル (11397), 品種 (9249), 無限 (9047), 一覧 (8615), myrng (8275), 行, (8005), ーブ (5971)
- 『複数ブックから複数条件に合致する文字列を抽出し転記したい』（こば）
こんにちは。質問ですが、[[20210630143416]]を参考にして種類ごとに分かれた商品リストのブックを参照して、条件に合う文字列を別ブックに転記するマクロを作成しています。 _|___A____|___B____|___C____|___D____|__ 1| | | | | 2| | | | | 3| 品種 |地区 |収穫量 |種類 | 4|紅玉 |A地区 |B |リンゴ | 5|紅玉 |B地区 |C |リンゴ | ・・・テストデータフォルダ内のリンゴ、ぶどうなど7種類のリスト 6|紅玉 |C地区 |A |リンゴ | 7|北斗 |A地区 |D |リンゴ | 8|北斗 |B地区 |C |リンゴ | 9|ふじ |A地区 |A |リンゴ | 10|トキ |A地区 |B |リンゴ | ・ ・ ・ 上記の表から地区名と収穫量と種類に合致する品種を別ブックの下記のようなシートに抽出します。 __|___A____|___B______ |___C_______|___D____|__ 1| | | | | 2| | | | | 3|A地区 |リンゴ |ブドウ |ナシ | 4|A | | |幸水 | 5|B |紅玉 |ピオーネ |あきづき| 6|C |ふじ | | | 7|D |北斗 | | | 8|B,D |紅玉|北斗 |ピオーネ |あきづき| 9|A,D |北斗 | | | | | | | | | | | | | ↓のマクロを実行した場合、「オブジェクトが必要です」とエラーが出ましたが、どこを修正すればよろしいでしょうか。 Sub test() Dim i As Long Dim sFileName As String Dim wb As Workbook Dim ws As Worksheet Dim s一覧 As Worksheet Dim sリスト As Worksheet Set s一覧 = Worksheets("一覧") Set sリスト = Worksheets("リスト") With s一覧 .Range("A:A").ClearContents sFileName = Dir(ThisWorkbook.Path & "¥テストデータ¥*.xlsx") i = 1 Do Until sFileName = "" .Cells(i, 1) = ThisWorkbook.Path & "¥テストデータ¥" & sFileName i = i + 1 sFileName = Dir() Loop End With Dim MyRNG As Range With sリスト For i = 1 To s一覧.Cells(s一覧.Rows.Count, 1).End(xlUp).Row Set wb = Workbooks.Open(s一覧.Cells(i, 1)) Set ws = wb.Worksheets(1) For Each MyRNG In .Range("A4:D9") Set MyRNG.Value = リスト抽出(ws.Range("A2").CurrentRegion.Resize(.Rows.Count - 1).Offset(1).Select, .Cells(2, 2).Value, .Cells(MyRNG.Row, "A").Value, .Cells(3, MyRNG.Column).Value) Next MyRNG Next End With ws.Parent.Close SaveChanges:=False End Sub ----------------------------------------------------------------------------------------------------------------- Function リスト抽出(表範囲 As Range, 地区 As String, ランク As String, 種類 As String) As String Dim buf As String, 行 As Long For 行 = 1 To 表範囲.Rows.Count If 表範囲.Cells(行, 2).Value = 地区 Then If 表範囲.Cells(行, 4).Value = 種類 Then If UBound(Filter(Split(ランク, ","), 表範囲.Cells(行, 3).Value)) > -1 Then buf = buf & 表範囲.Cells(行, 1).Value & "|" End If End If End If Next 行 If buf <> "" Then buf = Left(buf, Len(buf) - 1) リスト抽出 = buf End Function ＜ 使用 Excel:unknown、使用 OS:unknown ＞ ---- Set MyRNG.Value = リスト抽出(ws.Range("A2").CurrentRegion.Resize(.Rows.Count - 1).Offset(1).Select, .Cells(2, 2).Value, .Cells(MyRNG.Row, "A").Value, .Cells(3, MyRNG.Column).Value) ↑ とりあえず。。。^^; みたいな感じがするのですが。なにをなさっているのか、 教えて頂けますでせうか。m(_ _)m （隠居Z） 2021/10/14(木) 15:36 ---- 追伸 エクセル OS の名前&バージョンを明示頂くとアドバイス獲得率が上がるかもしれません m(__)m （隠居Z） 2021/10/14(木) 15:40 ---- ちょい見なので外しているかもですが setとselect は要らないのでは これ以上はテスト出来る環境作成不可なので 申し上げられません。これにて、私は失礼致します。 外していましたらお許しを、引き続き他の回答者様 の回答をお待ち下さいませ。m(_ _)m （隠居Z） 2021/10/14(木) 15:54 ---- [[20210630143416]] 『リスト形式の表から複数条件に合致する名前を抽出』（みちる） ↑参考にした質問です。 隠居Zさんご返信ありがとうございます。 >Set MyRNG.Value = リスト抽出(ws.Range("A2").CurrentRegion.Resize(.Rows.Count - 1).Offset(1).Select, .Cells(2, 2).Value, .Cells(MyRNG.Row, "A").Value, .Cells(3, MyRNG.Column).Value) ↑すいません。リスト抽出のFunction関数の範囲はA4からデータが入っているので、ws.Range("A4")でした。 例の表も間違えていました。まぎらわしいのでリンゴの例だけ載せます。 _|___A____|___B____|___C____|___D____|__ 1| | | | | 2| | | | | 3| 品種 |地区 |収穫量 |種類 | 4|紅玉 |A地区 |B |リンゴ | 5|紅玉 |B地区 |C |リンゴ | ・・・テストデータフォルダ内のリンゴ、ぶどうなど7種類のリスト 6|紅玉 |C地区 |A |リンゴ | 7|北斗 |A地区 |D |リンゴ | 8|北斗 |B地区 |C |リンゴ | 9|ふじ |A地区 |A |リンゴ | 10|トキ |A地区 |B |リンゴ | ・ ・ ・ 上記の表から地区名と収穫量と種類に合致する品種を別ブックの下記のようなシートに抽出します。 __|___A____|___B______ |___C_______|___D____|__ 1| | | | | 2| | | | | 3|A地区 |リンゴ |ブドウ |ナシ | 4|A |ふじ | | | 5|B |紅玉|トキ | | | 6|C | | | | 7|D |北斗 | | | 8|B,D |紅玉|トキ | | | | ||北斗 | | | 9|A,D |ふじ| 北斗 | | | | | | | | | | | | | 失礼いたしました。OSとバージョンは下記のとおりです。 ★OS:Windows10 Excelバージョン:2019 （こば） 2021/10/14(木) 16:13 ---- お世話になります。昨日の質問ですが、アドバイスを受けて試行錯誤しましたがまだ解決出来ません。 ステップインで確認したらFor Each〜Nextが無限ループを起こしていました。 なのでFor Each〜NextをFor i〜の前に置きましたら今度はFor Each〜Nextがセル範囲に対してループしてくれません。 どのように修正すればよろしいでしょうか? Sub test() Dim i As Long Dim sFileName As String Dim wb As Workbook Dim ws As Worksheet Dim s一覧 As Worksheet Dim sリスト As Worksheet Set s一覧 = Worksheets("一覧") Set sリスト = Worksheets("リスト") With s一覧 .Range("A:A").ClearContents sFileName = Dir(ThisWorkbook.Path & "¥テストデータ¥*.xlsx") i = 1 Do Until sFileName = "" .Cells(i, 1) = ThisWorkbook.Path & "¥テストデータ¥" & sFileName i = i + 1 sFileName = Dir() Loop End With Dim MyRNG As Range With sリスト For i = 1 To s一覧.Cells(s一覧.Rows.Count, 1).End(xlUp).Row Set wb = Workbooks.Open(s一覧.Cells(i, 1)) Set ws = wb.Worksheets(1) Set テーブル1 = ws.Range("テーブル1") For Each MyRNG In .Range("A4:D9") '★ここで無限ループが起こる Set MyRNG.Value = リスト抽出(ws.Range("テーブル1"), .Cells(3, 1).Value, .Cells(MyRNG.Row, "A").Value, .Cells(3, MyRNG.Column).Value) Next MyRNG Next End With ws.Parent.Close SaveChanges:=False End Sub ------------------------------------------------------------------------------------------------------------- Function リスト抽出(表範囲 As Range, 地区 As String, ランク As String, 種類 As String) As String Dim buf As String, 行 As Long For 行 = 1 To 表範囲.Rows.Count If 表範囲.Cells(行, 2).Value = 地区 Then If 表範囲.Cells(行, 4).Value = 種類 Then If UBound(Filter(Split(ランク, ","), 表範囲.Cells(行, 3).Value)) > -1 Then buf = buf & 表範囲.Cells(行, 1).Value & "|" End If End If End If Next 行 If buf <> "" Then buf = Left(buf, Len(buf) - 1) リスト抽出 = buf End Function （こば） 2021/10/15(金) 15:17 ---- 基本 For Each はループの要素数がきまっているので、無限ループにはならないはずです。 Set MyRNG.Value = リスト抽出( ・・・・ って、ここで、オブジェクトが必要です という実行時エラーになりませんか? そのままデバッグボタン押して続行すれば、そりゃ無限にエラー発生のループに陥りますが... 隠居Zさんが、Setいらないって書いてますよね? MyRNG.Value = リスト抽出( ・・・・ （´・ω・`） 2021/10/15(金) 16:09 ---- (´・ω・`）さんご返信ありがとうございます。 >基本 For Each はループの要素数がきまっているので、無限ループにはならないはずです。 すいません。無限ループは間違いでした。ブックを変更しながら、For Each〜Nextでセル範囲をループさせながらFunction関数を実行したいが、For i〜に戻らないという意味でした。 >MyRNG.Value = リスト抽出( ・・・・ すいません。質問にSETを書いしまいましたが、画面では消してあり、エラーは起きませんでした。 （こば） 2021/10/15(金) 16:37 ---- 申し訳ありませんが、質問内容と現在の問題点について再整理お願いします。 >すいません。質問にSETを書いしまいましたが、画面では消してあり、エラーは起きませんでした。 こういうやり取りは時間の無駄です。 （´・ω・`） 2021/10/15(金) 16:46 ---- ステップイン(ステップインボタン又はF8キー)でデバックしているようなので、 以下を確認してから、質問内容に整理をされたらどうでしょうか。 For Each MyRNG In .Range("A4:D9") '★ここで無限ループが起こる Debug.Print a.Address(0, 0, , 1) 'MyRNG.Value = ‾‾コメントアウトする Next MyRNG イミディエイトウィンドウにMyRNGが何なのか[ブック名]シート名!セルで表示されます。 ご自身が想定しているものであるか、まず確認してみては。 （tkit） 2021/10/15(金) 16:59 ---- ＞無限ループは間違いでした。ブックを変更しながら、 ＞For Each〜Nextでセル範囲をループさせながらFunction関数を実行したいが、 ＞For i〜に戻らないという意味でした。 ということは、 For i = 1 To s一覧.Cells(s一覧.Rows.Count, 1).End(xlUp).Row の s一覧.Cells(s一覧.Rows.Count, 1).End(xlUp).Row が1なのでは? (つまり見出し行しかない) （めいぷる） 2021/10/15(金) 17:05 ---- 申し訳ありません。何人かの方に回答を頂きましたが、質問の再整理させて頂きます。 （質問） 複数ブックから条件に合致する品種をリストに転記するマクロを作成したいです。 _|___A____|___B____|___C____|___D____|__ 1| | | | | 2| | | | | 3| 品種 |地区 |ランク |種類 | 4|紅玉 |A地区 |B |リンゴ | 5|紅玉 |B地区 |C |リンゴ | ・・・データフォルダ内のリンゴ、ぶどうなど7種類のブック 6|紅玉 |C地区 |A |リンゴ | 7|北斗 |A地区 |D |リンゴ | 8|北斗 |B地区 |C |リンゴ | 9|ふじ |A地区 |A |リンゴ | 10|トキ |A地区 |B |リンゴ | ・ ・ ・ 上記の表から地区名とランクと種類に合致する品種を下記のような様式のリストに転記します。 __|___A____|___B______ |___C_______|___D____|__ 1| | | | | 2| | | | | 3|A地区 |リンゴ |ブドウ |ナシ | 4|A |ふじ | | | 5|B |紅玉|トキ | | | 6|C | | | | 7|D |北斗 | | | 8|B,D |紅玉|トキ | | | | ||北斗 | | | 9|A,D |ふじ| 北斗 | | | | | | | | | | | | | （現在の問題点） 一回目のFor EachのFunction関数の終了後、For i〜に戻り、次のブックを開く前に次のFunction関数の処理が始まってしまいます。 Sub test() Dim i As Long Dim sFileName As String Dim wb As Workbook Dim ws As Worksheet Dim s一覧 As Worksheet Dim s生物情報 As Worksheet Set s一覧 = Worksheets("一覧") Set s生物情報 = Worksheets("リスト") With s一覧 .Range("A:A").ClearContents sFileName = Dir(ThisWorkbook.Path & "¥データ¥*.xlsx") i = 1 Do Until sFileName = "" .Cells(i, 1) = ThisWorkbook.Path & "¥データ¥" & sFileName i = i + 1 sFileName = Dir() Loop End With Dim MyRNG As Range Dim テーブル1 As Range With s生物情報 For i = 1 To s一覧.Cells(s一覧.Rows.Count, 1).End(xlUp).Row Set wb = Workbooks.Open(s一覧.Cells(i, 1)) Set ws = wb.Worksheets(1) Set テーブル1 = ws.Range("テーブル1") For Each MyRNG In .Range("B4:D9") MyRNG.Value = リスト抽出(ws.Range("テーブル1"), .Cells(3, 1).Value, .Cells(MyRNG.Row, "A").Value, .Cells(3, MyRNG.Column).Value) Next MyRNG '★Function関数終了後にここからFor i〜に戻りたいが、Function関数の処理が始まってしまう。 Next End With ws.Parent.Close SaveChanges:=False End Sub -------------------------------------------------------------------------------------------------------------------- Function リスト抽出(表範囲 As Range, 地区 As String, ランク As String, 種類 As String) As String Dim buf As String, 行 As Long For 行 = 1 To 表範囲.Rows.Count If 表範囲.Cells(行, 2).Value = 地区 Then If 表範囲.Cells(行, 4).Value = 種類 Then If UBound(Filter(Split(ランク, ","), 表範囲.Cells(行, 3).Value)) > -1 Then buf = buf & 表範囲.Cells(行, 1).Value & "|" End If End If End If Next 行 If buf <> "" Then buf = Left(buf, Len(buf) - 1) リスト抽出 = buf End Function （こば） 2021/10/15(金) 17:21 ---- よく分からないので、Functionは無視。 Sub test() Dim i As Long Dim sFileName As String Dim wb As Workbook Dim ws As Worksheet Dim s一覧 As Worksheet Dim s生物情報 As Worksheet Dim テーブル1 As Range Dim Result, rX As Range, rY As Range, n, rlstY, rsltX, buf, v Set s一覧 = Worksheets("一覧") Set s生物情報 = Worksheets("リスト") With s一覧 .Range("A:A").ClearContents sFileName = Dir(ThisWorkbook.Path & "¥データ¥*.xlsx") i = 1 Do Until sFileName = "" .Cells(i, 1) = ThisWorkbook.Path & "¥データ¥" & sFileName i = i + 1 sFileName = Dir() Loop End With With s生物情報.Range("B4:D9") '結果表示範囲 .ClearContents Result = .Value Set rX = .Offset(-1).Rows(1).Cells Set rY = .Offset(, -1).Columns(1).Cells End With For i = 1 To s一覧.Cells(s一覧.Rows.Count, 1).End(xlUp).Row Set wb = Workbooks.Open(s一覧.Cells(i, 1)) Set ws = wb.Worksheets(1) Set テーブル1 = ws.Range("テーブル1") For n = 1 To テーブル1.Rows.Count If テーブル1.Cells(n, 2) = s生物情報.Range("A3") Then '地区が合致 rsltX = Application.Match(テーブル1.Cells(n, 4), rX, 0) If IsNumeric(rsltX) Then For rlstY = 1 To UBound(Result) v = テーブル1.Cells(n, "C") If InStr("," & rY(rlstY, 1) & ",", "," & v & ",") Then buf = Result(rlstY, rsltX) Result(rlstY, rsltX) = buf & IIf(buf <> "", "|", "") & テーブル1.Cells(n, 1) End If Next rlstY End If End If Next n wb.Close SaveChanges:=False Next i s生物情報.Range("B4").Resize(UBound(Result), UBound(Result, 2)).Value = Result End Sub （半平太） 2021/10/15(金) 21:02 (微調整23:55) ---- ご返信遅くなり申し訳ありません。 半平太さん、ありがとうございます。無事質問は解決しました! さらに追加で皆様にアドバイス頂きたいのですが、転記した文字列の種類ごとに、ランクAとCのみの合計をB10〜D10に追加したいのですが、自分で作成したマクロではtotal = total + arr(j)の部分で「型が一致しません」とエラーが出てしまいました。文字列の合計を求めるにはどう記述したらよいでしょうか? __|___A____|___B______ |___C_______|___D____|__ 1| | | | | 2| | | | | 3|A地区 |リンゴ |ブドウ |ナシ | 4|A |ふじ | | | 5|B |紅玉|トキ | | | 6|C | | | | 7|D |北斗 | | | 8|B,D |紅玉|トキ | | | | ||北斗 | | | 9|A,D |ふじ| 北斗 | | | 10|合計 | 1 | | | | | | | | Sub test() Dim i As Long Dim sFileName As String Dim wb As Workbook Dim ws As Worksheet Dim s一覧 As Worksheet Dim s生物情報 As Worksheet Dim テーブル1 As Range Dim Result, rX As Range, rY As Range, n, rlstY, rsltX, buf, v Set s一覧 = Worksheets("一覧") Set s生物情報 = Worksheets("リスト") With s一覧 .Range("A:A").ClearContents sFileName = Dir(ThisWorkbook.Path & "¥データ¥*.xlsx") i = 1 Do Until sFileName = "" .Cells(i, 1) = ThisWorkbook.Path & "¥データ¥" & sFileName i = i + 1 sFileName = Dir() Loop End With With s生物情報.Range("B4:D9") '結果表示範囲 .ClearContents Result = .Value Set rX = .Offset(-1).Rows(1).Cells Set rY = .Offset(, -1).Columns(1).Cells End With For i = 1 To s一覧.Cells(s一覧.Rows.Count, 1).End(xlUp).Row Set wb = Workbooks.Open(s一覧.Cells(i, 1)) Set ws = wb.Worksheets(1) Set テーブル1 = ws.Range("テーブル1") For n = 1 To テーブル1.Rows.Count If テーブル1.Cells(n, 2) = s生物情報.Range("A3") Then '地区が合致 rsltX = Application.Match(テーブル1.Cells(n, 4), rX, 0) If IsNumeric(rsltX) Then For rlstY = 1 To UBound(Result) v = テーブル1.Cells(n, "C") If InStr("," & rY(rlstY, 1) & ",", "," & v & ",") Then buf = Result(rlstY, rsltX) Result(rlstY, rsltX) = buf & IIf(buf <> "", "|", "") & テーブル1.Cells(n, 1) End If Next rlstY End If End If Next n wb.Close SaveChanges:=False Next i s生物情報.Range("B4").Resize(UBound(Result), UBound(Result, 2)).Value = Result Dim arr(1 To 2) As String ←★追加した合計を求めるマクロ arr(1) = Result(1, 2) arr(2) = Result(3, 2) Dim total As Long, j As Long For j = LBound(arr) To UBound(arr) total = total + arr(j) Next j s生物情報.Range("B10").Value = total End Sub （こば） 2021/10/19(火) 15:02 ---- よく分かりませんが、1に合わせるなら Dim arr(1 To 2) As String '←★追加した合計を求めるマクロ arr(1) = Result(1, 1) arr(2) = Result(3, 1) Dim total As Long, j As Long For j = LBound(arr) To UBound(arr) total = total + IIf(arr(j) = "", 0, UBound(Split(arr(j) & "|", "|"))) Next j s生物情報.Range("B10").Value = total （半平太） 2021/10/19(火) 15:59 ---- 半平太さん、ご返信ありがとうございます。 理想通りの結果になったのですが、種類の列が7列（〜H列）まである場合、どのように書き換えればよろしいでしょうか。お手数をおかけして申し訳ありませんが、ご教授頂ければ幸いです。 （こば） 2021/10/19(火) 16:31 ---- とりあえず、これで試してください。 Sub test() Dim i As Long, c As Long Dim sFileName As String Dim wb As Workbook Dim ws As Worksheet Dim s一覧 As Worksheet Dim s生物情報 As Worksheet Dim テーブル1 As Range Dim Result, rX As Range, rY As Range, n, rlstY, rsltX, buf, v Set s一覧 = Worksheets("一覧") Set s生物情報 = Worksheets("リスト") With s一覧 .Range("A:A").ClearContents sFileName = Dir(ThisWorkbook.Path & "¥データ¥*.xlsx") i = 1 Do Until sFileName = "" .Cells(i, 1) = ThisWorkbook.Path & "¥データ¥" & sFileName i = i + 1 sFileName = Dir() Loop End With With s生物情報.Range("B4:H10") '結果表示範囲 .ClearContents Result = .Value Set rX = .Offset(-1).Rows(1).Cells Set rY = .Offset(, -1).Columns(1).Cells End With For i = 1 To s一覧.Cells(s一覧.Rows.Count, 1).End(xlUp).Row Set wb = Workbooks.Open(s一覧.Cells(i, 1)) Set ws = wb.Worksheets(1) Set テーブル1 = ws.Range("テーブル1") For n = 1 To テーブル1.Rows.Count If テーブル1.Cells(n, 2) = s生物情報.Range("A3") Then '地区が合致 rsltX = Application.Match(テーブル1.Cells(n, 4), rX, 0) If IsNumeric(rsltX) Then For rlstY = 1 To UBound(Result) v = テーブル1.Cells(n, "C") If InStr("," & rY(rlstY, 1) & ",", "," & v & ",") Then buf = Result(rlstY, rsltX) Result(rlstY, rsltX) = buf & IIf(buf <> "", "|", "") & テーブル1.Cells(n, 1) End If Next rlstY End If End If Next n wb.Close SaveChanges:=False Next i '合計を求める For c = 1 To 7 For i = 1 To 3 Step 2 'AとC Result(7, c) = Result(7, c) + IIf(Result(i, c) = "", 0, UBound(Split(Result(i, c) & "|", "|"))) Next i Next c s生物情報.Range("B4:H10") = Result End Sub （半平太） 2021/10/19(火) 16:59 ---- 半平太さん、ありがとうございます!とても助かりました! 他の皆様もお付き合い下り、どうもありがとうございました。m（_ _）m （こば） 2021/10/19(火) 17:36... - https://www.excel.studio-kazu.jp/wiki/kazuwiki/202110/20211014143431.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97045 documents and 608218 words.
訪問者：