『複数の起票行を、1行にまとめたい』（s）
お世話になっております。
VBAは独学です、表題の件についてご質問させてください。
sheet1の内容を、あるルールのもとsheet2へ転記するといったデータ整理マクロを作成したいのですが
肝心のルール設定部分で躓いております。
有識者の方がいればどうかご教授いただけないでしょうか。
＜sheet1＞
A列 B C D E F 1 A100200 田中 太郎 新規 2025/2/20 妻 田中 恵子 2 A100200 田中 太郎 新規 2025/2/20 長女 田中 花子 3 A100200 田中 太郎 新規 2025/2/20 長男 田中 一郎 4 A100200 田中 太郎 新規 2025/2/20 次男 田中 次郎 5 A100200 田中 太郎 新規 2025/2/21 次女 田中 裕子 6 A100200 田中 太郎 新規 2025/2/21 三男 田中 三郎 7 A203000 鈴木 博 変更 2025/2/21 長女 鈴木 めぐみ 8 A100200 田中 太郎 新規 2025/2/21 三女 田中 明子 9 A203000 鈴木 博 変更 2025/2/21 次女 鈴木 まゆみ 10 A555555 佐藤 健太 その他 2025/2/21 妻 佐藤 由美子
＜sheet2＞
A列 B C D E F G H I J K L 1 A100200 田中 太郎 新規 2025/2/20 妻 恵子 長女 花子 長男 一郎 次男 次郎 1 A100200 田中 太郎 新規 2025/2/20 三男 三郎 2 A203000 鈴木 博 変更 2025/2/21 長女 めぐみ 次女 まゆみ 3 A100200 田中 太郎 新規 2025/2/21 三女 明子 8 A555555 佐藤 健太 その他 2025/2/21 妻 由美子
１：sheet1のA列（社員ID）とC列（日付）が同一の起票があれば、5件分までは1行にまとめてsheet2へ転記。6件目からは、次の行へ起票
２：Asheet1のE列は名前のみ記載（姓名は全角スペースで区切られている）
＜ 使用 Excel：Microsoft365、使用 OS：Windows10 ＞
＜sheet2＞
A列 B C D E F G H I J K L 1 A100200 田中 太郎 新規 2025/2/20 妻 恵子 長女 花子 長男 一郎 次男 次郎 2 A100200 田中 太郎 新規 2025/2/20 三男 三郎 3 A203000 鈴木 博 変更 2025/2/21 長女 めぐみ 次女 まゆみ 4 A100200 田中 太郎 新規 2025/2/21 三女 明子 5 A555555 佐藤 健太 その他 2025/2/21 妻 由美子 （s） 2025/02/20(木) 17:09:33
元データの方も直してもらわないと 5行目 田中 三郎 は 2025/2/20？ 4行目 田中 裕子 どこいった？ （´・ω・`） 2025/02/20(木) 17:32:17
マクロよりPower Queryのほうが簡単な気がします…
Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim v
Dim dic1 As Object, dic2 As Object
Dim i As Long
Dim s As String, key, n As Long
Set dic1 = CreateObject("scripting.dictionary")
Set dic2 = CreateObject("scripting.dictionary")
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
v = ws1.Cells(1).CurrentRegion.Value
For i = 1 To UBound(v)
s = v(i, 1) & vbTab & v(i, 2) & vbTab & v(i, 3) & vbTab & v(i, 4)
If Not dic1.exists(s) Then Set dic1(s) = CreateObject("system.collections.arraylist")
dic1(s).Add v(i, 5) & vbTab & Split(v(i, 6), " ")(1)
Next
For Each key In dic1.keys
n = n + 10
For i = 0 To dic1(key).Count - 1
s = CStr(n + i \ 3)
If Not dic2.exists(s) Then dic2(s) = key
dic2(s) = dic2(s) & vbTab & dic1(key)(i)
Next
Next
ws2.UsedRange.ClearContents
With ws2.Cells(1).Resize(dic2.Count)
.Value = Application.Transpose(dic2.items)
.TextToColumns Destination:=.Cells, DataType:=xlDelimited, _
Tab:=True, Semicolon:=False, Comma:=False, Space:=False, Other:=False
End With
End Sub （マナ） 2025/02/20(木) 21:17:34
こんばんは！
こんなデータがあったとしたら
|[A] |[B] |[C] |[D] |[E] |[F]
[1] |A100200|田中 太郎|新規 |2025/2/20|妻 |田中 恵子
[2] |A100200|田中 太郎|新規 |2025/2/20|長女|田中 花子
[3] |A100200|田中 太郎|新規 |2025/2/20|長男|田中 一郎
[4] |A100200|田中 太郎|新規 |2025/2/20|次男|田中 次郎
[5] |A100200|田中 太郎|新規 |2025/2/21|次女|田中 裕子
[6] |A100200|田中 太郎|新規 |2025/2/20|三男|田中 三郎
[7] |A203000|鈴木 博 |変更 |2025/2/21|長女|鈴木 めぐみ
[8] |A100200|田中 太郎|新規 |2025/2/21|三女|田中 明子
[9] |A203000|鈴木 博 |変更 |2025/2/21|次女|鈴木 まゆみ
[10]|A555555|佐藤 健太|その他|2025/2/21|妻 |佐藤 由美子
こんな感じになりました。
|[A] |[B] |[C] |[D] |[E] |[F] |[G] |[H] |[I] |[J] |[K] |[L]
[1]|A100200|田中 太郎|新規 |2025/2/20|妻 |恵子 |長女|花子 |長男|一郎|次男|次郎
[2]|A100200|田中 太郎|新規 |2025/2/20|三男|三郎 | | | | | |
[3]|A100200|田中 太郎|新規 |2025/2/21|次女|裕子 |三女|明子 | | | |
[4]|A203000|鈴木 博 |変更 |2025/2/21|長女|めぐみ|次女|まゆみ| | | |
[5]|A555555|佐藤 健太|その他|2025/2/21|妻 |由美子| | | | | |
Option Explicit
Sub てすと()
Dim x As Variant
Dim z As Variant
Dim w As Variant
Dim i As Long
Dim j As Long
Dim jj As Long
Dim k As Long
x = Sheets("Sheet1").Range("A1").CurrentRegion.Resize(, 37).Value
ReDim q(0)
ReDim y(0)
ReDim w(1 To 15, 1 To 2)
w(1, 1) = x(1, 1)
w(2, 1) = x(1, 2)
w(3, 1) = x(1, 37)
w(4, 1) = x(1, 23)
w(5, 1) = x(1, 18)
w(6, 1) = x(1, 25)
w(7, 1) = x(1, 26)
w(8, 1) = x(1, 25)
w(9, 1) = x(1, 26)
w(10, 1) = x(1, 25)
w(11, 1) = x(1, 26)
w(12, 1) = x(1, 25)
w(13, 1) = x(1, 26)
w(14, 1) = x(1, 25)
w(15, 1) = x(1, 26)
For i = LBound(x, 1) + 1 To UBound(x, 1)
z = Application.Match(x(i, 1) & "," & x(i, 18), q, 0)
If IsError(z) Then
ReDim g(1 To 7)
q(UBound(q)) = x(i, 1) & "," & x(i, 18)
g(1) = x(i, 1)
g(2) = x(i, 2)
g(3) = x(i, 37)
g(4) = x(i, 23)
g(5) = x(i, 18)
g(6) = x(i, 25)
g(7) = Right(x(i, 26), Len(x(i, 26)) - InStr(1, x(i, 26), " "))
y(UBound(y)) = g
ReDim Preserve q(UBound(q) + 1)
ReDim Preserve y(UBound(y) + 1)
Else
g = y(z - 1)
ReDim Preserve g(1 To UBound(g) + 2)
g(UBound(g) - 1) = x(i, 25)
g(UBound(g)) = Right(x(i, 26), Len(x(i, 26)) - InStr(1, x(i, 26), " "))
y(z - 1) = g
End If
Next
ReDim Preserve q(UBound(q) - 1)
ReDim Preserve y(UBound(y) - 1)
For i = LBound(y) To UBound(y)
k = 0
For j = LBound(y(i)) To UBound(y(i))
If ((j - 6) Mod 10 = 0) * (j > 6) Then
k = 0
ReDim Preserve w(1 To 15, 1 To UBound(w, 2) + 1)
For jj = LBound(w, 1) To 5
k = k + 1
w(jj, UBound(w, 2)) = w(jj, UBound(w, 2) - 1)
Next
k = k + 1
w(k, UBound(w, 2)) = y(i)(j)
Else
k = k + 1
w(k, UBound(w, 2)) = y(i)(j)
End If
Next
ReDim Preserve w(1 To 15, 1 To UBound(w, 2) + 1)
Next
With Sheets("Sheet2")
.Cells.Clear
.Range("A1").Resize(UBound(w, 2), UBound(w, 1)).Value = Application.Transpose(w)
End With
Erase x, w, q, y, g
End Sub
後は応用していただけますと幸いです。 では、おやすみなさいzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz （SoulMan） 2025/02/20(木) 22:13:11
A列 B C D E F G H I J K L M N O P Q R S T U V W X Y Z AA AB AC AD AE AF AG AH AI AJ AK AL 1 項1 項2 項3 項4 項5 項6 項7 項8 項9 項10 項11 項12 項13 項14 項15 項16 項17 項18 項19 項20 項21 項22 項23 項24 項25 項26 項27 項28 項29 項30 項31 項32 項33 項34 項35 項36 項37 項38 2 A100200 田中 太郎 ● ● ● ● ● ● ● ● ● ● ● ● ● ● ● 2025/2/20 ● null null null 新規 ● 妻 田中 恵子 ● ● null null ● ● ● ● ● ● ▼ ● 3 A100200 田中 太郎 ● ● ● ● ● ● ● ● ● ● ● ● ● ● ● 2025/2/20 ● null ● null 新規 ● 長女 田中 花子 ● ● null null null ● null null null null ▼ ● 4 A100200 田中 太郎 ● ● ● ● ● ● ● ● ● ● ● ● ● ● ● 2025/2/20 null null null null 新規 ● 長男 田中 一郎 ● ● null null null ● null null null null ▼ ● 5 A100200 田中 太郎 ● ● ● ● ● ● ● ● ● ● ● ● ● ● ● 2025/2/20 null ● null null 新規 ● 次男 田中 次郎 ● ● ● null null ● null null ● ● ▼ ● 6 A100200 田中 太郎 ● ● ● ● ● ● ● ● ● ● ● ● ● ● ● 2025/2/20 null ● null null 新規 ● 次女 田中 裕子 ● ● null null null ● null null null null ▼ ● 7 A100200 田中 太郎 ● ● ● ● ● ● ● ● ● ● ● ● ● ● ● 2025/2/21 null null null null 新規 ● 三男 田中 三郎 ● ● null null null ● ● ● null null ▼ ● 8 A203000 鈴木 博 ● ● ● ● ● ● ● ● ● ● ● ● ● ● ● 2025/2/21 null null null null 変更 ● 長女 鈴木 めぐみ ● ● null null ● ● ● ● ● ● ▼ ● 9 A100200 田中 太郎 ● ● ● ● ● ● ● ● ● ● ● ● ● ● ● 2025/2/21 null null null null 新規 ● 三女 田中 明子 ● ● null null null ● null null null null ▼ ● 10 A203000 鈴木 博 ● ● ● ● ● ● ● ● ● ● ● ● ● ● ● 2025/2/21 null null null null 変更 ● 次女 鈴木 まゆみ ● ● null null null ● null null null null ▼ ● 11 A555555 佐藤 健太 ● ● ● ● ● ● ● ● ● ● ● ● ● ● ● 2025/2/21 null null null null その他 ● 妻 佐藤 由美子 ● ● null null null ● null null null null ▼ ●
＜sheet2＞
A列 B C D E F G H I J K L M N O 1 項1 項2 項37 項23 項18 項25-1 項26-1 項25-2 項26-2 項25-3 項26-3 項25-4 項26-4 項25-5 項26-5 2 A100200 田中 太郎 ▼ 新規 2025/2/20 妻 恵子 長女 花子 長男 一郎 次男 次郎 次女 裕子 3 A100200 田中 太郎 ▼ 新規 2025/2/20 三男 三郎 三女 明子 4 A203000 鈴木 博 ▼ 変更 2025/2/21 長女 めぐみ 次女 まゆみ 5 A555555 佐藤 健太 ▼ その他 2025/2/21 妻 由美子
例に誤りがありすみません。
マナさんのコードだとエラーが出てしまったため、SoulManさんのコードで試したところ、
例で出した表では無事理想の組み合わせが出来ました、ありがとうございます。
実際の表で活用しようと変数などを変えてみたのですが
g(j) = x(i, j)部分でエラーが出てしまいうまく出来ません。
上記が実際の表になります。（例で出したのより列が多いです。）
こちらで使用する場合、置換が必要な場所はどちらになりますでしょうか
たびたびすみませんが、よろしくお願いいたします・・・
（s） 2025/02/21(金) 11:57:39
新しく例示した＜sheet1＞9行目の田中太郎さんの行、項18の日付が2025/2/21、三女 田中 明子、とありますが、
＜sheet2＞では、項目18の日付が2025/2/20 の行にまとめられていますよ。
項目18に表示する日付は古いものを優先すればいいのでしょうか？
追加の条件を加えて再質問するのなら、
最低限、おかしなところが無いか確認してから投稿するのが礼儀だと思います。
（mow） 2025/02/21(金) 12:28:47
Sub test2()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim v
Dim dic1 As Object, dic2 As Object
Dim i As Long
Dim s As String, key, n As Long
Set dic1 = CreateObject("scripting.dictionary")
Set dic2 = CreateObject("scripting.dictionary")
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
v = ws1.Cells(1).CurrentRegion.Value
For i = 2 To UBound(v)
s = v(i, 1) & vbTab & v(i, 2) & vbTab & v(i, 27) & vbTab & v(i, 23) & vbTab & v(i, 18)
If Not dic1.exists(s) Then Set dic1(s) = CreateObject("scripting.dictionary")
dic1(s)(dic1(s).Count) = v(i, 25) & vbTab & Split(v(i, 26), " ")(1)
Next
For Each key In dic1.keys
n = n + 10
For i = 0 To dic1(key).Count - 1
s = CStr(n + i \ 3)
If Not dic2.exists(s) Then dic2(s) = key
dic2(s) = dic2(s) & vbTab & dic1(key)(i)
Next
Next
ws2.UsedRange.Offset(1).ClearContents
With ws2.Cells(2, 1).Resize(dic2.Count)
.Value = Application.Transpose(dic2.items)
.TextToColumns Destination:=.Cells, DataType:=xlDelimited, _
Tab:=True, Semicolon:=False, Comma:=False, Space:=False, Other:=False
End With
End Sub （マナ） 2025/02/21(金) 16:21:13
こんばんは！
上のコードをなおしておきました。
使用したデータです。
|[A] |[B] |[C] |[D]|[E]|[F]|[G]|[H]|[I]|[J] |[K] |[L] |[M] |[N] |[O] |[P] |[Q] |[R] |[S] |[T] |[U] |[V] |[W] |[X] |[Y] |[Z] |[AA] |[AB]|[AC]|[AD]|[AE]|[AF]|[AG]|[AH]|[AI]|[AJ]|[AK]|[AL]
[1] |項1 |項2 | 項3|項4|項5|項6|項7|項8|項9|項10|項11|項12|項13|項14|項15|項16|項17|項18 | 項19|項20|項21|項22|項23 |項24|項25|項26 | 項27|項28|項29|項30|項31|項32|項33|項34|項35|項36|項37|項38
[2] |A100200|田中 太郎|● |● |● |● |● |● |● |● |● |● |● |● |● |● |● |2025/2/20|● |null|null|null|新規 |● |妻 |田中 恵子 |● |● |null|null|● |● |● |● |● |● |▼ |●
[3] |A100200|田中 太郎|● |● |● |● |● |● |● |● |● |● |● |● |● |● |● |2025/2/20|● |null|● |null|新規 |● |長女|田中 花子 |● |● |null|null|null|● |null|null|null|null|▼ |●
[4] |A100200|田中 太郎|● |● |● |● |● |● |● |● |● |● |● |● |● |● |● |2025/2/20|null |null|null|null|新規 |● |長男|田中 一郎 |● |● |null|null|null|● |null|null|null|null|▼ |●
[5] |A100200|田中 太郎|● |● |● |● |● |● |● |● |● |● |● |● |● |● |● |2025/2/20|null |● |null|null|新規 |● |次男|田中 次郎 |● |● |● |null|null|● |null|null|● |● |▼ |●
[6] |A100200|田中 太郎|● |● |● |● |● |● |● |● |● |● |● |● |● |● |● |2025/2/20|null |● |null|null|新規 |● |次女|田中 裕子 |● |● |null|null|null|● |null|null|null|null|▼ |●
[7] |A100200|田中 太郎|● |● |● |● |● |● |● |● |● |● |● |● |● |● |● |2025/2/20|null |null|null|null|新規 |● |三男|田中 三郎 |● |● |null|null|null|● |● |● |null|null|▼ |●
[8] |A203000|鈴木 博 |● |● |● |● |● |● |● |● |● |● |● |● |● |● |● |2025/2/21|null |null|null|null|変更 |● |長女|鈴木 めぐみ|● |● |null|null|● |● |● |● |● |● |▼ |●
[9] |A100200|田中 太郎|● |● |● |● |● |● |● |● |● |● |● |● |● |● |● |2025/2/20|null |null|null|null|新規 |● |三女|田中 明子 |● |● |null|null|null|● |null|null|null|null|▼ |●
[10]|A203000|鈴木 博 |● |● |● |● |● |● |● |● |● |● |● |● |● |● |● |2025/2/21|null |null|null|null|変更 |● |次女|鈴木 まゆみ|● |● |null|null|null|● |null|null|null|null|▼ |●
[11]|A555555|佐藤 健太|● |● |● |● |● |● |● |● |● |● |● |● |● |● |● |2025/2/21|null |null|null|null|その他|● |妻 |佐藤 由美子|● |● |null|null|null|● |null|null|null|null|▼ |●
結果です。
|[A] |[B] |[C] |[D] |[E] |[F] |[G] |[H] |[I] |[J] |[K] |[L] |[M] |[N] |[O]
[1]|項1 |項2 |項37|項23 |項18 |項25|項26 |項25|項26 |項25|項26|項25|項26|項25|項26
[2]|A100200|田中 太郎|▼ |新規 |2025/2/20|妻 |恵子 |長女|花子 |長男|一郎|次男|次郎|次女|裕子
[3]|A100200|田中 太郎|▼ |新規 |2025/2/20|三男|三郎 |三女|明子 | | | | | |
[4]|A203000|鈴木 博 |▼ |変更 |2025/2/21|長女|めぐみ|次女|まゆみ| | | | | |
[5]|A555555|佐藤 健太|▼ |その他|2025/2/21|妻 |由美子| | | | | | | |
後は、答えが合うように数字をいじってみてください。 では、、では、、また （SoulMan） 2025/02/21(金) 20:14:48
ちなみにマナさんのは↓を s = CStr(n + i \ 3)
これに↓変えたらできましたよ s = CStr(n + i \ 5) （SoulMan） 2025/02/21(金) 21:30:00
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.