[[20210615165159]]　『条件を変えながらオートフィルタで抽出し、指定セ』（みちる）　ページの最後に飛ぶ

『条件を変えながらオートフィルタで抽出し、指定セルに転記する』（みちる）

		A地区	B地区
品種	種類	収穫量	収穫量
紅玉　　リンゴ	A	C
王林	リンゴ	B	A
つがる	リンゴ	A	A
ふじ	リンゴ	C	C
北斗	リンゴ	C	A　　　・・・・
巨峰	ブドウ	A	A
ピオーネブドウ	D	B
幸水　　ナシ　　A　　　 C
あきづきナシ　　C　　　 D

上記のようなデータベースからオートフィルタを使い、地区ごとの収穫量のランクに応じた各種類の品種名を抽出し、別シートのセルに転記するマクロを考えていますが、上手くいきません。
ネットやこちらの掲示板で質問しながら自分で組んでみましたが、以下のようになりました。※途中段階ですが、これをアレンジして完成させたいです。

良い方法があればご教授願いたいと存じます。

（やりたいこと）
例：A地区の収穫量Aのうち、リンゴを絞り込み、品種名をSheet2のB４セルに改行とカンマを加えて転記する。B５に移動し、リンゴの収穫量Bを転記する。
Dまで転記が済んだら、C４に移動し、収穫量Aのうちのブドウと・・・なるようにしたいと考えています。

（悩んでいること）
転記するセルの移動の方法と複数条件での絞り込みが終わったあとに種類の条件を変えてもう一度同じ処理をループさせる方法が分からない状態です。

Option Explicit
Option Base 1

Sub Test2()

Dim rank As Variant
Dim bunrui As Variant
Dim i As Long
Dim MaxRow As Long
Dim j As Long
Dim buf As Range

rank = Array("A", "B", "C", "D")
bunrui = Array("リンゴ", "ブドウ", "ナシ")

MaxRow = Cells(Rows.Count, 1).End(xlUp).Row

For j = 1 To 5

For i = 1 To 4

With Range(Cells(3, 2), Cells(MaxRow, 5))

            .AutoFilter Field:=4, Criteria1:=rank(i)
            .AutoFilter Field:=2, Criteria1:=bunrui(j)
End With

With Worksheets("Sheet2").Range("B" & i + 3)

        For Each buf In Worksheets("Sheet1").Range("B4", Worksheets("Sheet1").Cells(Rows.Count, "B").End(xlUp)).SpecialCells(xlCellTypeVisible).Areas
            If IsArray(buf.Value) Then
                .Value = .Value & IIf(.Value = "", "", vbLf) & Join(WorksheetFunction.Transpose(buf.Value), "," & vbLf)
            Else
                .Value = .Value & IIf(.Value = "", "", vbLf) & buf.Value & ","
            End If
        Next
      End With

Next i

i = i + 1

Loop

Next j

End Sub

＜使用 Excel：Excel2019、使用 OS：Windows10 ＞

 ちょい乱暴(いやかなり^^;)ですけど、考え方のひとつとしての例示なのでご勘弁。
 たとえば

    Function 条件2つで抽出(抽出範囲 As Range, デリミタ As String, _
                           検索範囲1 As Range, 検索条件1 As String, _
                           検索範囲2 As Range, 検索条件2 As String) As String
        Dim i As Long, ary() As Variant, c As Long
        ReDim ary(1 To 抽出範囲.Cells.Count)
        For i = 1 To 抽出範囲.Cells.Count
            If 検索範囲1.Cells(i).Value = 検索条件1 And 検索範囲2.Cells(i).Value = 検索条件2 Then
                c = c + 1
                ary(c) = 抽出範囲.Cells(i).Value
            End If
        Next
        If c = 0 Then Exit Function
        ReDim Preserve ary(1 To c)
        条件2つで抽出 = Join(ary, デリミタ)
    End Function

 などという関数を作っちゃえば、
 極端な話、ワークシート上でだって使えちゃいます。

 __|___A____|___B____|___C____|___D____|___E____|___F____|___G____|___H____|_____I_____|___J____|___K____
  1|        |        |        |        |        |        |        |        |           |        |        
  2|        |        |A地区   |B地区   |        |        |        |        |           |        |        
  3|品種    |種類    |収穫量  |収穫量  |        |        |        |A地区   |リンゴ     |ブドウ  |ナシ    
  4|紅玉    |リンゴ  |A       |C       |        |        |        |A       |紅玉|つがる|巨峰    |幸水    
  5|王林    |リンゴ  |B       |A       |        |        |        |B       |王林       |        |        
  6|つがる  |リンゴ  |A       |A       |        |        |        |C       |ふじ|北斗  |        |あきづき
  7|ふじ    |リンゴ  |C       |C       |        |        |        |D       |           |ピオーネ|        
  8|北斗    |リンゴ  |C       |A       |        |        |        |        |           |        |        
  9|巨峰    |ブドウ  |A       |A       |        |        |        |        |           |        |        
 10|ピオーネ|ブドウ  |D       |B       |        |        |        |        |           |        |        
 11|幸水    |ナシ    |A       |C       |        |        |        |        |           |        |        
 12|あきづき|ナシ    |C       |D       |        |        |        |        |           |        |

 I4 =条件2つで抽出($A$4:$A$12,"|",$B$4:$B$12,I$3,$C$4:$C$12,$H4)

 そんな風に、
 「この条件で抽出する」って作業と
 「条件を巡回する」という部分を切り離して組み立ててみては如何でしょう?

（白茶） 2021/06/15(火) 20:42

ご返信ありがとうございます！(^▽^)
完成形では別シートで地区を検索フォームで絞り込む形にしたかったのでこのやり方でもよいのかもしれません！
追加のご質問なのですが、ワークシートの式に文字列の最後にカンマを加えて改行をする式を作るにはどうしたらよいでしょうか。下記のような式を作成しましたが、最後の文字列にカンマがつかないようでして...。
もし追加で教えて頂ければ幸いです。_(._.)_

=条件2つで抽出($A$4:$A$12,","&CHAR(10),$B$4:$B$12,I$3,$C$4:$C$12,$H4)　
（みちる） 2021/06/15(火) 23:07

 お?
 結果にデリミタを付け加えるだけでしたら...

 条件2つで抽出 = Join(ary, デリミタ) & デリミタ
                                    ~~~~~~~~~~~追記
 でイケるかと思いますが...?

（白茶） 2021/06/16(水) 10:20

ご返信ありがとうございます。

私の知識不足で()の中に記述していましたのでエラーが起こってしまいました。(^^;
白茶さんの言う通りにしましたらちゃんと成功しました。

最後までお付き合いくださいましてどうもありがとうございます！

（みちる） 2021/06/16(水) 10:38

すいません。気が付いていただければ幸いなのですが、収穫量の列に空白セルが含まれている場合、求めた結果が出ないでしょうか。

本番用のデータベースを参照したところ、空白が表示されてしまいました。
（みちる） 2021/06/16(水) 11:17

すいません。こちらで参照先を誤っていました。
無事結果を得られることが出来ました。

ご迷惑をかけて申し訳ありません。
改めましてどうもありごとうございました。(^^;
（みちる） 2021/06/16(水) 11:28

コメント返信：

[ 一覧(最新更新順) ]

[[20210615165159]] 『条件を変えながらオートフィルタで抽出し、指定セ』（みちる） ページの最後に飛ぶ

[[20210615165159]]　『条件を変えながらオートフィルタで抽出し、指定セ』（みちる）　ページの最後に飛ぶ