重複するＩＤのデータを1行にまとめるvbaのコード

1か月分（1日～月末まで）の手当申請をした日の集計をするためexcel　vbaで次のような
コードを作りたく、お知恵を拝借できますでしょうか。

シート1に元データが1,000件程あります。
シート2に、シート1のＩＤが同じものをまとめ、日付を日付順に横に表示したいです。

同じＩＤは最大で20回ほど登場、1度の申請で最大10日分のデータがあります。

ＩＤ 　氏名 　所属　　日付1　 日付2　 日付3　 日付4　 日付5　 日付6　… …　日付10
1000　田中　営業部　　9/1　　9/2　　9/7
2000　佐藤　業務部　　9/2　
2000　佐藤　業務部　　9/11
2000　佐藤　業務部　　9/13　 9/15
3000　山田　製造部　　9/4　　9/11　 9/12　　9/15　　9/16
3000　山田　製造部　　9/18　 9/20　 9/23　　9/24　　9/25
：
↓

1000　田中　営業部　　9/1　 　9/2　　9/7
2000　佐藤　業務部　　9/2　　 9/11　 9/13　　9/15
3000　山田　製造部　　9/4　　 9/11　 9/12　　9/15　　9/16　　9/18　… … 9/25

：
どなたかこのような動作を行うvbaのコードを教えてください。
よろしくお願いいたします。

No.4 ベストアンサー 回答者： ppp2122 回答日時： 2020/11/02 16:44

質問者どの

手元のサンプルでは　正しく動作し、
日付が消えることもありません
ちなみにルーチンは
メインとルーチン１、ルーチン2を全部貼り付けしていますよね？
そしてメインを実行していますよね？
ルーチン１だけ実行だとそうなります

この回答へのお礼

ppp2122様

追加のコードを見直していただきありがとうございます。
最初 ルーチン１ だけで実行していたようでした……。
改めて記載いただいた追加コードを入れて「メイン」で実行したら、希望通りの内容で記載がされました！
（完璧な内容で感動です！！）
本当にありがとうございました。

お礼日時：2020/11/02 19:22

No.3 回答者： ppp2122 回答日時： 2020/11/02 16:39

Ｎｏ２氏どうも

確かにその例の場合はそのようになりますね
下のほうのコードを
h = 1
For j = 4 To 13
.Cells(i, j).Value = hairetu(h)
h = h + 1
Next j

▽　▽　▽　これを追加
For h=1 to 20
hairetu(h)=""
next h
△　△　△　ここまで
Next i
End With

End Sub

配列の要素数の取得はしていません
テキトーで　ゼロも使いません
即席で作ったので勘弁してほしいです

あとは質問者さんご自身で　きれなコードに仕上げてください
とりあえず動きます

No.2 回答者： tatsumaru77 回答日時： 2020/11/02 16:17

No1様

横から失礼します。
No1様のマクロを実行してみました。
添付図の山田の結果がおかしいように思われます。（黄色の部分）
ご確認をお願いいたします。

この回答へのお礼

tatsumaru77様

動作確認いただきありがとうございます。
ppp2122様に再度コードの見直しをしてもらえることとなり、大変助かりました。

お礼日時：2020/11/02 19:18

No.1 回答者： ppp2122 回答日時： 2020/11/02 14:10

こういう事ですかね？

シート名はご自身のシートに合わせてください
抽出データ貼り付け用に１つシートを必要とします
サンプルでは元データ　Sheet1
抽出データ　Sheet2としてあります
データは開始行＝２
列は1列目から始まっています
無駄が多いコードですが
とりあえず手元では動作しました
メインを実行してください

Sub メイン()

Call ルーチン1
Call ルーチン2
End Sub

Sub ルーチン1()
Dim lastRow1 As Long, lastRow2 As Long
Dim i As Long, j As Long, myCnt As Long
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Set WS1 = Worksheets("Sheet1")
Set WS2 = Worksheets("Sheet2")

With WS2
.Range("A:A").ClearContents
.Range("A2:c2") = WS1.Range("A2:c2").Value
lastRow1 = WS1.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastRow1
myCnt = 0
lastRow2 = .Cells(Rows.Count, 1).End(xlUp).Row
For j = 1 To lastRow2
If .Cells(j, 1).Value = WS1.Cells(i, 1).Value Then
Exit For
Else
myCnt = myCnt + 1
End If
Next j
If myCnt = lastRow2 Then
.Cells(lastRow2 + 1, 1).Value = WS1.Cells(i, 1).Value
.Cells(lastRow2 + 1, 2).Value = WS1.Cells(i, 2).Value
.Cells(lastRow2 + 1, 3).Value = WS1.Cells(i, 3).Value
End If
Next i
End With
End Sub

Sub ルーチン2()
Dim lastRow1 As Long, lastRow2 As Long
Dim i As Long, j As Long, k As Long, h As Long, myCnt As Long
Dim ID As String
Dim hairetu(20) As Variant
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Set WS1 = Worksheets("Sheet1")
Set WS2 = Worksheets("Sheet2")
lastRow1 = WS1.Cells(Rows.Count, 1).End(xlUp).Row
lastRow2 = WS2.Cells(Rows.Count, 1).End(xlUp).Row


With WS2
For i = 2 To lastRow2
ID = .Cells(i, 1).Value
h = 1
For j = 2 To lastRow1
If WS1.Cells(j, 1).Value = ID Then
For k = 4 To 10
If WS1.Cells(j, k).Value <> "" Then
hairetu(h) = WS1.Cells(j, k).Value
h = h + 1
End If

Next k

End If
Next j

h = 1
For j = 4 To 13
.Cells(i, j).Value = hairetu(h)
h = h + 1
Next j

Next i
End With

End Sub

この回答へのお礼

早速のご回答ありがとうございます。
コード実行したところ同じIDは集約されたのですが、日付が消えてしまい表記されませんでした。内容を確認して検証させていただきたいと思います。
お忙しいところお教えいただき、ありがとうございました！

お礼日時：2020/11/02 16:18