VBAで複数のセルの中から特定の値がA列に入っているもののみを抽出したい

Question

以下のようなExcelから各商品分類の区分名の中の売上額、利益額、数量のみをFor文よりも時間がかからず取り出すことは可能ですか？
今のやり方は一回目のfor文で(名前1)～(名前n)までを回し、二回目のfor文で行を回し、区分名が売上額、利益額、数量のどれかであれば別のシート(『まとめ』という名前です)に書き込むというようにしています。
しかし、このやり方では重いらしくたまに落ちてしまいます。
もし、もっと簡単もしくは重くないやり方などあればご教授いただければ幸いです。
*人の数や名前は変化するため、1~nにしてあります。始まりは変わらずN列からなのですが、終わりは増えたり減ったりする可能性もあります
一応自身の目的など分かりやすく書いたつもりではありますが、もしわかりにくかったら申し訳ございません。

[作成元のExcelシート]
|L|M|N|...|S|X|
|:--|:--:|:--:|:--:|
|分類名|区分名|(名前1)|...|(名前n)|計|
|(分類1)|売り上げ額|
| |利益額|
| |利益率|
| |数量|
| |平均原価|
|(分類2)|売り上げ額|
| |利益額|
| |利益率|
| |数量|
| |平均原価|

Sub 作成
Dim i As Integer
Dim j As Integer
Dim saigo As Integer '人の最終列
Dim num As Integer

'人の名前がどこからどこまでかを確認
For i = 14 To Sheets(1).Cells(6,Columns.count).End(xlToLeft).Column
   If Sheets(1).Cells(6,i) = "計" Then
      saigo = i-1
   End If
Next

'まとめシートに値を入れる
For i = 14 TO saigo
   For j = 1 To Sheets(1).Cells(Rows.count,i).End(xlUp).Row
      'ｴﾗｰもしくは空白の場合セルに0を入れる
      If Sheets(1).Cells(j,i) = "" Or IsError(Sheets(1.Cells(j,i)) Then
         Sheets(1).Cells(j,i) = 0
      EndIf

      If Sheets("まとめ").Cells(1,1) = "" Then
         Sheets("まとめ").Cells(1,1) = Sheets(1).Cells(12,i)
         Sheets("まとめ").Cells(1,2) = Sheets(1).Cells(13,i)
         Sheets("まとめ").Cells(1,3) = Sheets(1).Cells(12,i)
      Else
         num = Sheets("まとめ").Cells(Rows.count,1).End(xlUp).Row + 1
         Sheets("まとめ").Cells(num,1) = Sheets(1).Cells(j,i)
         Sheets("まとめ").Cells(num,2) = Sheets(1).Cells(j,i)
         Sheets("まとめ").Cells(num,3) = Sheets(1).Cells(j,i)
      End If
   Next
Next
Next
End Sub

[最終的に出来て欲しい内容(まとめシート)]

A	B	C
(分類1)	(名前1)	売上額
(分類1)	(名前1)	利益額
(分類1)	(名前1)	数量
(分類2)	(名前1)	売上額
(分類2)	(名前1)	利益額
(分類2)	(名前1)	数量
.	(名前1)	数量
.	(名前1)	数量
.	(名前1)	数量
(分類1)	(名前n)	売上額
(分類1)	(名前n)	利益額
(分類1)	(名前n)	数量
(分類2)	(名前n)	売上額
(分類2)	(名前n)	利益額
(分類2)	(名前n)	数量

Answer 1

すいません自己解決してしまいました
計の一つ手前をFindで取得しAutoFilterで三項目のみを取得することにしました。
案をだしてくださってありがとうございます。これからの資料作成に役立てたいと思います。

Answer 2

こんにちはこんばんは、よろしくおねがいいたします。

たぶん・・私の理解が不足していると思うので、下記のアイディアはご期待に沿ってないかもしれませんが・・ご参考になさってください。

「"計"の文字が出現するいっこ前まで繰り返す」部分の動作は、do while loopを使いました。

下記のサンプルコードで私のほうでは動作確認できました。

Option Explicit

Sub Tenki()
'作成元シートからまとめシートに転記するVBAです

Dim SakuseimotoSheet As Worksheet
Dim MatomeSheet As Worksheet
'作成元シートは、”作成元.xlsx"の"Sheet1"であるとします
'まとめシートは、このワークブックの"Sheet1"であるとします
'このVBAは、このワークブック（まとめシートがあるブック）にあるものとします
'作成元.xlsxはすでに開かれているものとします

Set SakuseimotoSheet = Workbooks("作成元").Worksheets("sheet1") '作成元シートを定義します
Set MatomeSheet = ThisWorkbook.Worksheets("Sheet1") 'まとめシートを定義します

Dim i As Long '作成元シート側にて、列番号を制御する変数です
Dim j As Long 'まとめシート側にて、印字する行番号を制御する変数です

i = 14  '作成元シートの１行目の名前のサーチは１４列目（L列）からスタートします
j = 1 'まとめシートへの転記は１行目からスタートします

Dim Namae, Bunrui_1, Uriagegaku_1, RiekiGaku_1, Suryo_1 As String '各アイテムを格納する変数です
Dim Bunrui_2, Uriagegaku_2, RiekiGaku_2, Suryo_2 As String  '各アイテムを格納する変数です

Do While SakuseimotoSheet.Cells(6, i) <> "計"  '「計」という文字列に当たるまで繰り返します
  '作成元シートから、各アイテムの値を得ます
  With SakuseimotoSheet
    Namae = .Cells(6, i).Value
    Bunrui_1 = .Cells(7, 12).Value  '分類１の名称は、このセルに固定で存在しているので、これでいいと思います
    Uriagegaku_1 = .Cells(7, i).Value
    RiekiGaku_1 = .Cells(8, i).Value
    Suryo_1 = .Cells(10, i).Value
    Bunrui_2 = .Cells(12, 12).Value '分類２の名称は、このセルに固定で存在しているので、これでいいと思います
    Uriagegaku_2 = .Cells(12, i).Value
    RiekiGaku_2 = .Cells(13, i).Value
    Suryo_2 = .Cells(15, i).Value
  End With

  '各アイテムの値を、まとめシートに転記します
  '分類１と分類２の２分類があって、それぞれの売上額・利益額・数量の３要素があるので、
  '結果的に２ｘ３＝６要素を単純にひとかたまりととらえて、いっぺんに転記させます

  With MatomeSheet
    .Cells(j, 1) = Bunrui_1
    .Cells(j, 2) = Namae
    .Cells(j, 3) = Uriagegaku_1

    .Cells(j + 1, 1) = Bunrui_1
    .Cells(j + 1, 2) = Namae
    .Cells(j + 1, 3) = RiekiGaku_1

    .Cells(j + 2, 1) = Bunrui_1
    .Cells(j + 2, 2) = Namae
    .Cells(j + 2, 3) = Suryo_1

    .Cells(j + 3, 1) = Bunrui_2
    .Cells(j + 3, 2) = Namae
    .Cells(j + 3, 3) = Uriagegaku_2

    .Cells(j + 4, 1) = Bunrui_2
    .Cells(j + 4, 2) = Namae
    .Cells(j + 4, 3) = RiekiGaku_2

    .Cells(j + 5, 1) = Bunrui_2
    .Cells(j + 5, 2) = Namae
    .Cells(j + 5, 3) = Suryo_2
  End With

  j = j + 6 ' まとめシート側で６行送ります
  i = i + 1 '作成シート側で１列右に移動します

Loop

End Sub

Answer 3

すみません、質問です
「まとめシート」の出力行はどこでカウントアップしていますか？

行2(分類1) (名前1) 売上額
行3(分類1) (名前1) 利益額

と出力されることになっていますが、行の2,3...とカウントアップしている変数はどこでしょう。

Comments

[porpora_0316]

分かりにくくて申し訳ございません
まとめシートの出力行は、num = Sheets("まとめ").Cells(Rows.count,1).End(xlUp).Row+1で最終行の次の行を取得することでカウントアップしています(A1が空白の場合はA1から値を入れ、それ以外の場合は最終行の次の行に値を入れる)