『VBAでグループごとに振り分け』（ヘンリー）
A1セルに"ID"
B1セルに"グループ"
と入っています。
A2セルからA54セルまでは、
"001"〜"053"
が入っています(実際は順不同)
B2セルからB54セルまでは
1〜4までが繰り返し入っています。
(グループが1〜nと変動※nは2〜6の間
例では仮に4にしている)
以下のような感じです。
【元データ】
ID グループ
001 1
002 2
003 3
004 4
005 1
006 2
007 3
008 4
009 1
010 2
011 3
012 4
・ ・
・ ・
・ ・
053 1
これを、
D1セルに"グループNo"
D2セルに1
D3セルに2
D4セルに3
D5セルに4
と入力して、
E2セルからR2セルまでに出力したいです。
(グループごとに以下のように出力したい)
【出力データ】
1 001 005 009 …
2 002 006 010 …
3 003 007 011 …
4 004 008 012 …
Microsoft365では、E2セルに
「=TRANSPOSE(FILTER($A$2:$A$54,$B$2:$B$54=D2,""))」
と入力し、4行分オートフィルすればできるのですが、
Filter関数の使えない。Excel2016でも動作するように、
VBAでしたいです。
元データを1行ずつ読み込み、
1の時はE列の2行目のn列
2の時はE列の3行目のn列
3の時はE列の4行目のn列
4の時はE列の5行目のn列
(nを1つづカウントしていく)
のように書くことはできると思うのですが、
元データを1行ずつ読み込みながら
グループ1だけの配列
グループ2だけの配列
グループnだけの配列
に格納して、配列をセルに代入するような
イメージでVBAを作ることは可能でしょうか。
グループ数も動的配列
出力するIDも動的配列
になると思うのですが、
どのように組んでよいかわかりません。
出力時は、IDの数だけResizeしてセルに代入するのかと思うのですが、
ちょっとしたヒントでも構いませんので、
ご教授いただけないでしょうか。
よろしくお願いいたします。
＜ 使用 Excel：Excel2016、使用 OS：Windows10 ＞
Excel365なら E2セルに =WRAPCOLS(A2:A54,4,"") ですかね。(4はグループ数）
VBAなら愚直にこんな感じですか?
Sub test()
Dim m&, p&
Dim mat() As String
Dim k&, r&, c&
m = 4 '■グループ数を指定
p = Application.Ceiling(53 / m, 1)
ReDim mat(1 To m, 1 To p)
For k = 1 To 53
r = (k - 1) Mod m + 1
c = Int((k - 1) / m) + 1
mat(r, c) = Cells(k + 1, "A")
Next
With [E2].Resize(m, p)
.NumberFormatLocal = "@"
.Value = mat
End With
End Sub
もっと気の利いたものは色々あるでしょうけど、一応基本的なものということで。
（xyz） 2025/08/02(土) 11:36:29
横からですが、
＞グループ1だけの配列 ＞グループ2だけの配列 ＞グループnだけの配列 ＞に格納して
この部分がですが、 質問者さんは、二次元配列についてご理解されていますか？
今回のケースであれば、私もxyzさんと同様に二次元配列を利用しますし、 グループ毎の配列が必要であれば、Application.Index(mat,1) 等として、 任意のグループの配列を取り出すと思います。 （unknown） 2025/08/02(土) 11:47:59
初めて見たのですが、
変数の宣言の「m&」の「&」にはどのような意味があるのでしょうか。
追加質問ですみませんが、ご教授いただけるとありがたいです。
unknown様、ご回答ありがとうございます。
＞二次元配列についてご理解されていますか？
理解はできていません。
使用したことはありますが、
列数が固定になっていることが多く、
Type〜End Typeで列名をつくって、
行方向のみを動的配列にして二次元配列を作っていました。
＞Application.Index(mat,1)
も試してみます。
（ヘンリー） 2025/08/02(土) 12:55:04
＞Filter関数の使えない。Excel2016でも動作するように、VBAでしたいです。
別案 UDF
E2; =Filterlike($A$2:$B$54,2,D2,1) 2 = 第一引数の範囲何に対する相対条件列インデックス 1 = 第一引数の範囲何に対する相対抽出列インデックス
Function FilterLike(r As Range, idRef&, ID, ref&)
Dim x
If Not IsNumeric(ID) Then ID = Chr(34) & ID & Chr(34)
With r
x = Filter(.Parent.Evaluate("transpose(if(" & .Columns(idRef).Address & "=" & _
ID & ",row(1:" & .Rows.Count & ")))"), False, 0)
If UBound(x) > -1 Then
FilterLike = Application.Index(r.Value, Application.Transpose(x), ref)
If UBound(x) > 0 Then FilterLike = Application.Transpose(FilterLike)
End If
End With
End Function
（jindon） 2025/08/02(土) 14:14:54
Option Explicit
Sub Exzample_One()
Dim Dc As Object
Dim i As Long
Dim lR As Long
Dim k As Variant
Dim iT As Variant
Dim r As Range
Dim dK() As Variant
Set Dc = CreateObject("Scripting.Dictionary")
With Worksheets("Sheet1")
lR = .Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lR
k = .Cells(i, 2).Value
iT = .Cells(i, 1).Value
Dc(k) = Dc(k) & iT & ","
Next
dK = Dc.keys
.Copy
End With
With ActiveSheet
.UsedRange.Clear
For i = 0 To UBound(dK)
With .Cells(i + 1, 1)
.Value = dK(i)
.Offset(, 1).Resize(, UBound(Split(Dc(dK(i)), ","))) = Split(Dc(dK(i)), ",")
End With
Next
Set r = .Cells(1).CurrentRegion
r.Sort key1:=r.Columns(1), order1:=xlAscending, Header:=xlNo
End With
Erase dK
Dc.RemoveAll
End Sub
おあとがよろしいようで。。。。<< _ _ >>
（隠居Z） 2025/08/02(土) 14:31:52
>変数の宣言の「m&」の「&」にはどのような意味 「型宣言文字」というものです。 VBEでLongと書いて、F1を押してヘルプを読んでみて下さい。書かれていますよ。 Dim m As Longと書くのと同じです。 Long(&),Integer(%),String($), Double(#),Single(!)などがあります。（すべての型にあるわけではないです。頻度重視） Dim mat$()と書かないと一貫しないじゃないか、という指摘は甘んじて?受けます。まあその時の気分もあります。
行を順次進めて、限度を超えたら、1に戻して列を進める、といった考え方でも勿論書けるでしょう。 （xyz） 2025/08/02(土) 14:48:00
隠居Z様、ご回答ありがとうございます。
Dictionaryを使うこともできるのですね。
保存しておいて、後でいろいろ検証いたします。
xyz様、たびたびご回答ありがとうございます。
型宣言文字について調べてみました。
今まで使ったことがないのでびっくりしました。
＞r = (k - 1) Mod m + 1
＞c = Int((k - 1) / m) + 1
ここの部分の発想が出てきませんでした。
複数検証した結果、自分の思っていた通りの結果になりました。
算数のできない私にとっては
この計算式(ロジック)が出ませんでした。
おかげさまで実ファイルでもできました。
ご回答くださった皆様、
参考になるご指導、本当にありがとうございました。
（ヘンリー） 2025/08/02(土) 15:46:03
jindonさん FilterLike関数興味深く拝見しました。 この関数は返り値の長さが可変ですが、Excel365より前のものでも支障なく動作するのでしょうか。 配列数式のようにして、事前に領域を確保しなくてもOKなんでしょうか。 私には生憎環境が無いので、教えて頂けると幸いです。 （xyz） 2025/08/03(日) 12:00:02
＞Filter関数の使えない。Excel2016でも動作するように、VBAでしたいです。 おっしゃる通り自分で参照しておいてバージョンを考慮していませんでした。
FilterLikeはスピル機能が実装されたバージョンでなければ機能しません。
以前のバージョンでも、ということでむしろINDEX関数の変形として
=myIndex($A$2:$B$55,$D$2:$D$5,2,1,ROW(A1),COLUMN(A1)) 右方、下方へフィル $A$2:$B$55 = 元データ参照領域 $D$2:$D$5 = 抽出条件範囲 2 = 第一引数の範囲何に対する相対条件列インデックス 1 = 第一引数の範囲何に対する相対抽出列インデックス ROW(A1)及びCOLUMN(A1)は単に行列インデックスの代用なので左最上セルは必ずA1
Function myIndex(r1 As Range, r2 As Range, idRef&, ref&, Rowref&, Colref&)
Dim a, b, i&, ii&
a = r2: b = r1
ReDim c(1 To UBound(b, 1), 1 To UBound(b, 1)) As String
ReDim Preserve a(1 To UBound(a, 1), 1 To 2)
For ii = 1 To UBound(b, 1)
For i = 1 To UBound(a, 1)
If a(i, 1) = b(ii, idRef) Then
a(i, 2) = a(i, 2) + 1
c(i, a(i, 2)) = b(ii, ref)
End If
Next
Next
myIndex = c(Rowref, Colref)
End Function
（jindon） 2025/08/03(日) 17:04:57
回答いただきありがとうございました。助かりました。
計算効率の点からいうと、各セルで配列全体をその都度計算しているような気がしまして、 配列を返すUDFにしておいて、 4行14列のセル範囲に配列数式をセットしたほうがいいような気がしました。
いずれにせよ、お手数おかけしまして、ありがとうございました。
（xyz） 2025/08/03(日) 18:42:56
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.