該当のセルのみを2次元配列に入れる方法

該当の行のみを2次元配列に入れる方法について教えて下さい

最初は、フィルターで絞って、コピー→別シートに貼り付け、2次元配列にいれていましたが
ややこしいことがあり、同じシートのみを使用することになりました。
また、そのシートのセルの削除とかも出来ない状態です

めちゃくちゃデータ数が多いので、出来ればフィルーター→どこかに貼り付けはしたくないのですが。。。。




一様別の2次元配列に格納も考えたのですが、要素数の上限を宣言する必要があるらしく
この場合は焼肉の数は把握できますが、実際に使用するデータはその時によって、焼肉の数が変わるので、上限数を宣言するのは出来なくて出来ません
Redimで上限数を何回も変えるのも気持ち悪いし・・・
何かいい方法はないでしょうか？

よろしくお願いします。

Option Explicit
Sub input_yakiniku()

Dim i As Long

Dim yakiniku_rows As Long
Dim yakiniku_col As Long

Dim all_hairetsu As Variant
Dim yakiniku_haretsu As Variant

Dim maxrow As Long
Dim maxcol As Long


Cells(1, 1) = "名前"
Cells(1, 2) = "金額"
Cells(1, 3) = "ランク"



For i = 2 To 10000

If i Mod 2 = 0 Then

_Cells(i, 1) = "焼肉"
_If i Mod 3 = 0 Then
__Cells(i, 2) = 500
__Cells(i, 3) = "A"
_ElseIf i Mod 4 = 0 Then
__Cells(i, 2) = 600
__Cells(i, 3) = "B"
_Else
Cells(i, 2) = 1000
Cells(i, 3) = "C"
_End If


Else
_Cells(i, 1) = "すき焼き"
_If i Mod 3 = 0 Then
__Cells(i, 2) = 200
__Cells(i, 3) = "D"

_Else
__Cells(i, 2) = 300
__Cells(i, 3) = "F"
_End If

End If



Next

maxrow = Cells(Rows.Count, 1).End(xlUp).Row
maxcol = Cells(1, Columns.Count).End(xlToLeft).Column


all_hairetsu = Range(Cells(1, 1), Cells(maxrow, maxcol)).Value

yakiniku_rows = 0


For i = 1 To maxrow
_If Cells(i, 1) = "焼肉" Then
__For yakiniku_col = 1 To 3

___Cells(yakiniku_rows, yakiniku_col) = all_hairetsu(i, yakiniku_col)
__Next
_End If
Next



End Sub

質問者からの補足コメント

• excel 2016です。

    補足日時：2021/09/07 18:12

• この質問をまとめると、焼肉（名前、金額、ランク）専用の配列を作る

    補足日時：2021/09/07 18:16

No.4 ベストアンサー 回答者： Qchan1962 回答日時： 2021/09/07 23:00

＃１です

＞For i = 2 To 10000　はデモデータを作る為のものと解釈しています。

処理速度の問題だったのでしょうか？
配列でソートする方法も色々とありますが、

＞めちゃくちゃデータ数が多いので、出来ればフィルーター→どこかに貼り付けはしたくないのですが。。。。

ちょっとなさりたい事が分からないのですが、

したくないExcelの機能のソートとフィルタを使ってコピーする方法です
元データは初めに配列に入れて最後に戻しています。ソートやフィルターの結果は元に戻ります。
ループは使わずに済みます。

Sub Extraction_Data()
Dim allhairetsu As Variant
Dim yakiniku_Ary As Variant
Dim ws As Worksheet
Set ws = ActiveSheet
allhairetsu = Range("A1").CurrentRegion
Application.ScreenUpdating = False
With ws.Sort
With .SortFields
.Clear
.Add Key:=ws.Range("A1"), Order:=xlAscending
End With
.SetRange ws.Range("A1").CurrentRegion
.Header = xlYes
.Apply
End With

Range("A1").AutoFilter 1, "焼肉"
With Range("A1").CurrentRegion.Offset(1, 0)
' yakiniku_Ary = .Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
.Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy Range("E2")
End With
ws.Range("A1").CurrentRegion.AutoFilter

Cells(1, 1).Resize(UBound(allhairetsu, 1), UBound(allhairetsu, 2)) = allhairetsu
' Cells(2, 5).Resize(UBound(yakiniku_Ary, 1), UBound(yakiniku_Ary, 2)) = yakiniku_Ary
Application.ScreenUpdating = True

End Sub

コピーならソートする必要はないように思いますが、配列を作る事を
想定して連続データにしています。
書式などをコピーしたくない場合はコピー部分をコメントにして、
現在コメントにしている部分（配列）で実行してください。


＞2次元配列に入れる方法について教えて下さい
デモデータ作成部分も配列で行うと処理速度は速くなりますね
Sub Make_DemData()
Dim i As Long, n As Long
Dim DemoAry(9999, 2)
DemoAry(0, 0) = "名前"
DemoAry(0, 1) = "金額"
DemoAry(0, 2) = "ランク"
For i = 1 To 9999
If i Mod 2 = 0 Then
DemoAry(i, 0) = "焼肉"
If i Mod 3 = 0 Then
DemoAry(i, 1) = 500
DemoAry(i, 2) = "A"
ElseIf i Mod 4 = 0 Then
DemoAry(i, 1) = 600
DemoAry(i, 2) = "B"
Else
DemoAry(i, 1) = 1000
DemoAry(i, 2) = "C"
End If
Else
DemoAry(i, 0) = "すき焼き"
If i Mod 3 = 0 Then
DemoAry(i, 1) = 200
DemoAry(i, 2) = "D"
Else
DemoAry(i, 1) = 300
DemoAry(i, 2) = "F"
End If
End If
Next
Application.ScreenUpdating = False
Cells(1, 1).Resize(UBound(DemoAry, 1) + 1, UBound(DemoAry, 2) + 1) = DemoAry
Application.ScreenUpdating = True
End Sub

この回答へのお礼

そんなループを使わない方法があったとは！有難うございます。

お礼日時：2021/09/08 19:54

No.5 回答者： fujillin 回答日時： 2021/09/07 23:12

No3です

お礼を読みました。
＞シート操作だと、かなり時間がかかるので、出来れば配列でやりたいのが本音ですね。
というのに、はなはだ疑問を感じました。（私の予想とは真逆なので）


シート上のデータをソートしても良いものと仮定して（データ順を保存しなくても良いものと仮定）

ご提示の10000行のデータで試してみました。
Time関数で測定してみると、私の環境では、
　・ご提示のデータを作成するのに約50～60秒程度
　・シートのソートに0秒
という結果です。

どうやらTime関数では測定できないので、Windows APIでミリ秒単位で測定してみると、ソートには
　・0.17～0.18秒
程度を要しているようです。
これを遅いと考えるのか速いと考えるのかは、質問者様の判断によりますけれど・・・
少なくとも、VBAで処理するのと同等以上ではあるものと想像します。


＞不要なすき焼きのデータも含むことになるのと
xlDescendingでソートして、「すき焼き」の最初の行をFINDで探せば、「焼肉」の範囲がわかりますので、変数配列に値を代入するのが目的の場合でも一発で処理は終わります。
仮に「すき焼き」といワードが不明の場合でも、目的とする「焼肉」の最初の行と最後の行を探せば良いので、ほぼ同様の処理で終わるでしょう。

＞配列でソートが出来ればいいのですが
こちらは試していませんけれど、多分、シートのソートの方が速いのではないかと想像します。
（理由としては、VBAそのものが遅いので・・・）

この回答へのお礼

言葉足らずで失礼しました。

確かにこれだけの処理では、ソートの方が早いですが
焼肉のデータでもっといろんなことをするので・・・配列じゃないと処理時間がかかるのです

また、findで最初の行を探すのも参考になります。

お礼日時：2021/09/08 19:37

No.3 回答者： fujillin 回答日時： 2021/09/07 20:52

こんばんは

横からで、失礼いたします。

ざっとしかみていないので、勘違いかも知れませんけれど・・・
データを上書きしているようなのと、
＞1万ループして、さらに3回るーぷですが、～～
とあるので、最終的にはA列の内容別にまとめて並べ替えたいのかと解釈しました。


もしそうであるなら、シート上でそのままソートしたほうが簡単なのではないでしょうか？
単純な昇順・降順などではなく順序を指定順にしたいのであれば、ひと手間増えますけれど「CustomOrder」を利用すれば好きな順にすることも可能なはずです。
実行時間を比較してはいませんけれど、エクセルの内部計算で行ってくれるので、インタプリタ型のVBAでいろいろ処理をするよりも速いのではないかと想像します。

あるいは、シートのデータはそのまま残しておきたくて、あくまでも変数配列上にデータが欲しいというのであるなら、all_hairetsuを直接ソートしてしまうという方法もあるかもしれません。
VBAには配列のソートメソッドがないので（シートのソートはありますけれど）、VBAで記述する必要が出てきますが…
こちらの場合は、既回答との時間的な優劣は不明です。
（採用するソートのロジックにもよると思いますが、3回やるのならソートの方が速いのではないかと）


※ 私の勘違いでしたなら、無視してください。

この回答へのお礼

ご回答ありがとうございます。

ソートだと、不要なすき焼きのデータも含むことになるのと
シート操作だと、かなり時間がかかるので、出来れば配列でやりたいのが本音ですね。

そうですね・・・配列でソートが出来ればいいのですが

お礼日時：2021/09/07 21:06

No.2 回答者： Qchan1962 回答日時： 2021/09/07 19:36

#1です

試してみたら、少し（だいぶ）違いました
訂正します
＃１の方法　
正
Dim n As Long, j As Long
Dim TestAry()
For i = 1 To UBound(all_hairetsu, 1)
If all_hairetsu(i, 1) = "焼肉" Then
For j = 0 To UBound(all_hairetsu, 2) - 1
ReDim Preserve TestAry(UBound(all_hairetsu, 2) - 1, n)
TestAry(j, n) = all_hairetsu(i, j + 1)
Next
n = n + 1
End If
Next

確認してください

＞素早くいけました。
セルに書き出すのを一度に行っている為と思われます。

この回答へのお礼

わざわざすいません、有難うございます。
はい、こちらの希望していた形になりました。
1万ループして、さらに3回るーぷですが、こちらもスムーズにできて良かったです。

お礼日時：2021/09/07 19:47

No.1 回答者： Qchan1962 回答日時： 2021/09/07 19:08

こんばんは

＞この質問をまとめると、焼肉（名前、金額、ランク）専用の配列を作る
For i = 1 To maxrow
If Cells(i, 1) = "焼肉" Then
For yakiniku_col = 1 To 3
Cells(yakiniku_rows, yakiniku_col) = all_hairetsu(i, yakiniku_col)
Next
End If
Next
個々の部分と解釈すると

Dim n As Long, j As Long
Dim TestAry()
For i = 1 To UBound(all_hairetsu, 1)
If all_hairetsu(i, 1) = "焼肉" Then
For j = 1 To UBound(all_hairetsu, 2)
ReDim Preserve TestAry(UBound(all_hairetsu, 2), n)
TestAry(j, n) = all_hairetsu(i, j)
Next
n = n + 1
End If
Next

Cells(2, 5).Resize(UBound(TestAry, 2) + 1, UBound(TestAry, 1) + 1) = Application.Transpose(TestAry)

こんな感じかな
E2セルより行方向に出力しています

この回答へのお礼

早速ありがとうございます。
ReDim 使用するの、とても遅くなるかなと思いきや、素早くいけました。
助かります！

お礼日時：2021/09/07 19:29