『シートのデータをID別に振り分けたい』（pc00）
すみません
このような表から下記のような人別、週別のシートに手入力していますが、マクロでSとEだけでも転記できたらと思っていますが可能なものでしょうか？
元の表
W 年月日 ID 氏名 作業 終了日付 終了時間 開始日付 開始時間
24 2025/6/9 11 ああ S 2025/6/9 15:55
24 2025/6/9 11 ああ b 2025/6/9 16:47 2025/6/9 17:15
24 2025/6/9 11 ああ a 2025/6/9 17:55 2025/6/9 18:16
24 2025/6/9 11 ああ b 2025/6/9 18:17 2025/6/9 21:25
24 2025/6/9 11 ああ E 2025/6/9 21:28
24 2025/6/9 33 いい S 2025/6/9 23:39
24 2025/6/9 33 いい b 2025/6/10 0:22 2025/6/10 0:25
24 2025/6/9 33 いい b 2025/6/10 0:25 2025/6/10 0:38
24 2025/6/9 33 いい c 2025/6/10 6:59 2025/6/10 7:25
24 2025/6/9 33 いい E 2025/6/10 8:18
書き出す表
氏名 ああ
作業 S a b E
2025/6/9 15:55:00 21:28:04
2025/6/10
2025/6/11
2025/6/12
2025/6/13
2025/6/14
2025/6/15
＜ 使用 Excel：Excel2010、使用 OS：Windows10 ＞
１，書き出す表のシート名はどんな感じですか？ 「W24ID11ああ」てなシート名なのですか？
２．SとEだけの転記だとして、それでも作業名は「SabE」の様に全部必要なんですか？
（半平太） 2026/05/23(土) 21:10:17
（pc00） 2026/05/23(土) 22:23:28
＞idにしたらbookが週毎になり 意味がよく分からないです。
週別のシートを作るんですよね？ 週番号を入れれば、シートは別々になるので、同一ブックで問題ないと思うのですが。
もう一度お聞きします。各自のシート名がどうなるのか教えてください。
＞aとｂは不規則なので、手入力でと考えています それをマクロで自動化しなかったら、マクロの有難みが無くなりますよ？
＞２、３０名分で、１名1日８から１５行あります これは元の表の話ですね？ いずれにしても、同じW(A列）において、SとEは先頭と末尾に各１行しかないですね？
書き出す表は、1名1週間単位で各シート最多7行ですよね？
（半平太） 2026/05/23(土) 23:24:25
＞いずれにしても、同じW(A列）において、SとEは先頭と末尾に一行ずつしかないですね？ ↑ これは間違いでした。m(__)m
同じW(A列）、同じＩＤ において、SとEは同数あり、最多は各7つですね？
（半平太） 2026/05/23(土) 23:38:48
SとEは同日、先頭と末尾に各１行です
滅多にないですが、操作ミスで複数ある時も
1名1週間単位で各シート最多7行です
（pc00） 2026/05/23(土) 23:42:06
Dim wsMoto As Worksheet, wsSaki As Worksheet
Dim lastRow As Long, i As Long
Dim sName As String
Dim dic As Object
' 元シートの設定
Set wsMoto = Sheets("Sheet1")
lastRow = wsMoto.Cells(wsMoto.Rows.Count, "A").End(xlUp).Row
' 振り分け先のシート名をリスト化するためにDictionaryを使用
Set dic = CreateObject("Scripting.Dictionary")
' A列の値を重複しないようにDictionaryに格納
For i = 2 To lastRow
sName = wsMoto.Cells(i, 1).Value
If Not dic.exists(sName) Then dic.Add sName, Nothing
Next i
' 各シートへデータを振り分け
Dim key As Variant
For Each key In dic.keys
' シートが存在するかチェックし、なければ作成
On Error Resume Next
Set wsSaki = Sheets(key)
If Err.Number <> 0 Then
Sheets.Add(After:=Sheets(Sheets.Count)).Name = key
Set wsSaki = ActiveSheet
' 見出しをコピー（元データが1行目の場合）
wsMoto.Rows(1).EntireRow.Copy wsSaki.Rows(1)
End If
On Error GoTo 0
' 既存データをクリア（見出しは残す）
wsSaki.Range("A2:XFD" & wsSaki.Rows.Count).ClearContents
' フィルターをかけてデータ抽出・転記
With wsMoto.Range("A1").CurrentRegion
.AutoFilter Field:=1, Criteria1:=key
.Offset(1).EntireRow.Copy wsSaki.Range("A2")
End With
' オートフィルターを解除
wsMoto.AutoFilterMode = False
Next key
wsMoto.Activate
MsgBox "振り分けが完了しました！", vbInformation
End Sub
（pc００） 2026/05/24(日) 20:55:18
<<元の表>>のレイアウトは以下のようになっています（「ページのソース表示」で確認済み）
W 年月日 ID 氏名 作業 終了日付 終了時間 開始日付 開始時間 24 2025/6/9 11 ああ S 2025/6/9 15:55 24 2025/6/9 11 ああ b 2025/6/9 16:47 2025/6/9 17:15 24 2025/6/9 11 ああ a 2025/6/9 17:55 2025/6/9 18:16 24 2025/6/9 11 ああ b 2025/6/9 18:17 2025/6/9 21:25 24 2025/6/9 11 ああ E 2025/6/9 21:28 24 2025/6/9 33 いい S 2025/6/9 23:39 24 2025/6/9 33 いい b 2025/6/10 0:22 2025/6/10 0:25 24 2025/6/9 33 いい b 2025/6/10 0:25 2025/6/10 0:38 24 2025/6/9 33 いい c 2025/6/10 6:59 2025/6/10 7:25 24 2025/6/9 33 いい E 2025/6/10 8:18
そもそも ・11さんの最初の作業 b は、いつ開始していつ終了したものですか？ 読みかたがわからない。 ・とりあえず S とEだけだそうですが、他の作業の転記の仕方によっては 今回提示されている作業の仕様にも影響してきます。 例えば、 ・11さんには、bが２回発生しますが、それはどこに書き出されるんですか？ ・作業の種類がもっとあれば、Eの時刻を書く列も右にズレてこないのですか？
もう少し丁寧に説明して、少なくとも提示されたデータが、どう書きこみされるのか 省略せずにキチンと提示されたらどうですか？ 少なくともそれが示されない限り前には進まないと思いますよ。
# 提示されたコードの出典（URL）を示して下さい。
（xyz） 2026/05/24(日) 21:42:38
とりあえず作ってみました。 深夜またぎがあったりして、いま一つしっくり来ないデータに見えますけども・・
作成されたブックは、デスクトップ画面上の「PC00」フォルダに書き込みます。 ※空のフォルダをデスクトップ上に予め作っておいてください。
実行するマクロ名は「Extract_SE_Data」です。
Private Const stName As String = "S" '先頭業務名 Private Const edName As String = "E" '末尾業務名
Private dicWeeNojobName As Object Private dicNameFmID As Object Private dicExtract As Object Private wsDupli As Worksheet Private App As Application
Sub Extract_SE_Data()
Dim ky, kys, stTime, edTime
Dim lastRow As Long, i As Long, nn As Long
Dim WEE, DAT, ID, sName, jobNamesSofar, jobName, jobNames
Dim DataByWEEKandID(1 To 7, 1 To 3)
Dim vArray
Call init 'Dicrionaryを初期化
With ThisWorkbook
.Worksheets("元の表").Copy After:=.Worksheets(.Worksheets.Count)
End With
Set wsDupli = Worksheets(Worksheets.Count)
SortInOrderByKey wsDupli '並べ替え
lastRow = wsDupli.Cells(wsDupli.Rows.Count, "A").End(xlUp).Row
For i = 2 To lastRow
WEE = wsDupli.Cells(i, "A").Value
DAT = wsDupli.Cells(i, "B").Value
ID = CStr(wsDupli.Cells(i, "C").Value)
sName = wsDupli.Cells(i, "D").Value
jobName = wsDupli.Cells(i, "E").Value
edTime = wsDupli.Cells(i, "G").Value
stTime = wsDupli.Cells(i, "I").Value
'週番とIDと年度で合成キーを作成
ky = WEE & "♪" & ID & "♪" & Year(DAT)
dicNameFmID(ID) = sName 'IDと氏名を紐づけ
If jobName <> stName And jobName <> edName Then 'S,E以外を週別/ID別に収集
jobNames = dicWeeNojobName(ky)
jobNamesSofar = Split("♪" & jobNames, "♪")
If jobNamesSofar(UBound(jobNamesSofar)) <> jobName Then '新作業名を追加
dicWeeNojobName(ky) = jobNames & "♪" & jobName
End If
Else 'SまたはEのケース
If Not dicExtract.exists(ky) Then '新規
Erase DataByWEEKandID
DataByWEEKandID(1, 1) = DAT
If jobName = stName Then
DataByWEEKandID(1, 2) = stTime
Else
DataByWEEKandID(1, 3) = edTime
End If
dicExtract(ky) = DataByWEEKandID
Else '2データ以降
vArray = dicExtract(ky)
For nn = 1 To 7
If vArray(nn, 1) = DAT Or vArray(nn, 1) = "" Then
If vArray(nn, 1) = "" Then
vArray(nn, 1) = DAT
End If
If jobName = stName Then
vArray(nn, 2) = stTime
Else
vArray(nn, 3) = edTime
End If
dicExtract(ky) = vArray
Exit For
End If
Next nn
End If
End If
Next i
Erase DataByWEEKandID
dicExtract("999♪00") = DataByWEEKandID '最終のdummy書き込み
Call NewBookMaking
App.ScreenUpdating = False
App.DisplayAlerts = False
wsDupli.Delete
App.DisplayAlerts = True
App.ScreenUpdating = True
End Sub
Sub init()
Set dicWeeNojobName = CreateObject("Scripting.Dictionary")
Set dicNameFmID = CreateObject("Scripting.Dictionary")
Set dicExtract = CreateObject("Scripting.Dictionary")
Set App = Application
End Sub
Sub SortInOrderByKey(wsSrc As Worksheet)
With Worksheets(Worksheets.Count)
.Sort.SortFields.Clear
.Sort.SortFields.Add key:=Range("E2") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Sort.SetRange .UsedRange
.Sort.Header = xlYes
.Sort.Apply
.Sort.SortFields.Clear
.Sort.SortFields.Add key:=Range("A2"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Sort.SortFields.Add key:=Range("C2"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Sort.SortFields.Add key:=Range("B2"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Sort.SetRange .UsedRange
.Sort.Header = xlYes
.Sort.Apply
End With
End Sub
Private Sub NewBookMaking()
Dim path, ky, kys, prevWeek, curWeek
Dim existsSE(1 To 2) As Boolean 'S有り、E有り
Dim i As Long, yer As Long
Dim newBK As Workbook
Dim flNameToSave
Dim job
'個別Book作成
With CreateObject("WScript.Shell")
path = .SpecialFolders("Desktop")
End With
kys = dicExtract.keys
prevWeek = ""
For i = 0 To UBound(kys)
ky = kys(i)
curWeek = Split(ky, "♪")(0)
If prevWeek <> curWeek Then '前Weekブックを保存
If Not newBK Is Nothing Then
newBK.SaveAs Filename:=path & "\PC00\" & yer & "-" & _
flNameToSave, FileFormat:=xlOpenXMLWorkbook
App.DisplayAlerts = False
newBK.Worksheets(1).Delete
App.DisplayAlerts = True
newBK.Close True
End If
If curWeek = "999" Then
Exit Sub
End If
Set newBK = Workbooks.Add '新Book作成
Erase existsSE
flNameToSave = curWeek
prevWeek = curWeek
End If
With newBK.Worksheets.Add(After:=Worksheets(newBK.Worksheets.Count))
.Name = Split(ky, "♪")(1)
.Range("A1") = dicNameFmID(Split(ky, "♪")(1))
job = dicWeeNojobName(ky)
.Range("A3").Resize(7, 3) = dicExtract(ky)
yer = Year(.Range("A3").Value)
If Application.CountA(.Range("B3:B9")) Then
job = stName & job
End If
If App.CountA(.Range("C3:C9")) Then
job = job & "♪" & edName
End If
.Columns("B:C").NumberFormatLocal = "h:mm:ss;@"
.Columns("A:C").AutoFit
job = App.Trim(Replace(job, "♪", " "))
.Range("A2") = job
End With
Next
End Sub
（半平太） 2026/05/24(日) 23:01:43
書き出すのは下記で考えています
いまのところSEのみ必要です
氏名
日付 S時間 E時間
2025/6/9 15:55 空白 空白 21:28
↓この部分を修正するかクエリか何かで元データを成形できないかと考えました
' フィルターをかけてデータ抽出・転記
With wsMoto.Range("A1").CurrentRegion
.AutoFilter Field:=1, Criteria1:=key
.Offset(1).EntireRow.Copy wsSaki.Range("A2")
End With
' オートフィルターを解除
wsMoto.AutoFilterMode = False
（pc00） 2026/05/24(日) 23:08:16
使わせていただきまた報告に上がります
（pc00） 2026/05/24(日) 23:12:55
ああ
S a b E
2025/6/9 15:55:00 21:28:00
書き込み用のシートを用意しておいて書き込むことを考えていましたので勉強になりました。
贅沢をおねがいするようですが
氏名をb列 EをE列に入れることは可能でしょうか
A1 B1 E
氏名： ああ
作業： S 空白 空白 E
2025/6/9 15:55 空白 空白 21:28
（pc00） 2026/05/25(月) 15:18:05
全面書換版 ↓ Private Const stName As String = "S" '先頭業務名 Private Const edName As String = "E" '末尾業務名 Private App As Application
Sub Extract_SE_Data()
Dim ky, kys, stTime, edTime
Dim lastRow As Long, i As Long, nn As Long
Dim WEE, DAT, ID, sName, jobName
Dim DataByWEEKandID(1 To 9, 1 To 5)
Dim vArray
Dim wsDupli As Worksheet
Dim dicExtract As Object
Set dicExtract = CreateObject("Scripting.Dictionary")
Set App = Application
With ThisWorkbook
.Worksheets("元の表").Copy After:=.Worksheets(.Worksheets.Count)
End With
Set wsDupli = Worksheets(Worksheets.Count)
SortInOrderByKey wsDupli '並べ替え W>ID>DATE
lastRow = wsDupli.Cells(wsDupli.Rows.Count, "A").End(xlUp).Row
For i = 2 To lastRow
WEE = wsDupli.Cells(i, "A").Value
DAT = wsDupli.Cells(i, "B").Value
ID = CStr(wsDupli.Cells(i, "C").Value)
sName = wsDupli.Cells(i, "D").Value
jobName = wsDupli.Cells(i, "E").Value
edTime = wsDupli.Cells(i, "G").Value
stTime = wsDupli.Cells(i, "I").Value
'週番とIDで合成キーを作成
ky = WEE & "♪" & ID
If jobName = stName Or jobName = edName Then 'S,Eのみ処理
If Not dicExtract.exists(ky) Then '新規
Erase DataByWEEKandID
DataByWEEKandID(1, 1) = "氏名:"
DataByWEEKandID(1, 2) = sName
DataByWEEKandID(2, 1) = "作業:"
DataByWEEKandID(3, 1) = DAT
If jobName = stName Then
DataByWEEKandID(2, 2) = jobName
DataByWEEKandID(3, 2) = stTime
Else
DataByWEEKandID(2, 5) = jobName
DataByWEEKandID(3, 5) = edTime
End If
dicExtract(ky) = DataByWEEKandID
Else '2データ以降
vArray = dicExtract(ky)
For nn = 3 To 9
If vArray(nn, 1) = DAT Or vArray(nn, 1) = "" Then
If jobName = stName Then
vArray(nn, 2) = stTime
vArray(2, 2) = jobName
Else
vArray(nn, 5) = edTime
vArray(2, 5) = jobName
End If
If vArray(nn, 1) = "" Then
vArray(nn, 1) = DAT
End If
dicExtract(ky) = vArray
Exit For
End If
Next nn
End If
End If
Next i
Erase DataByWEEKandID
dicExtract("999♪00") = DataByWEEKandID '最終のdummy書き込み
Call NewBookMaking(dicExtract)
App.ScreenUpdating = False
App.DisplayAlerts = False
wsDupli.Delete
App.DisplayAlerts = True
App.ScreenUpdating = True
dicExtract.RemoveAll
End Sub
Sub SortInOrderByKey(wsDup As Worksheet) '変更
With wsDup
.Sort.SortFields.Clear
.Sort.SortFields.Add Range("A2"), xlSortOnValues, xlAscending, xlSortNormal
.Sort.SortFields.Add Range("C2"), xlSortOnValues, xlAscending, xlSortNormal
.Sort.SortFields.Add Range("B2"), xlSortOnValues, xlAscending, xlSortNormal
.Sort.SetRange .UsedRange
.Sort.Header = xlYes
.Sort.Apply
End With
End Sub
Private Sub NewBookMaking(dicExtract)
Dim path, ky, kys, prevWeek, curWeek
Dim i As Long, yer As Long
Dim newBK As Workbook
Dim flNameToSave
'デスクトップPath取得
With CreateObject("WScript.Shell")
path = .SpecialFolders("Desktop")
End With
kys = dicExtract.keys
prevWeek = ""
For i = 0 To UBound(kys)
ky = kys(i)
curWeek = Split(ky, "♪")(0)
If prevWeek <> curWeek Then '新週間
If Not newBK Is Nothing Then
yer = Year(newBK.Worksheets(newBK.Worksheets.Count).Range("A3").Value)
newBK.SaveAs Filename:=path & "\PC00\" & yer & "-" & _
flNameToSave, FileFormat:=xlOpenXMLWorkbook
App.DisplayAlerts = False
newBK.Worksheets(1).Delete
App.DisplayAlerts = True
newBK.Close True
End If
If curWeek = "999" Then
Exit Sub
End If
Set newBK = Workbooks.Add '新Book作成
flNameToSave = curWeek
prevWeek = curWeek
End If
With newBK.Worksheets.Add(After:=newBK.Worksheets(newBK.Worksheets.Count))
.Name = Split(ky, "♪")(1)
.Range("A1").Resize(9, 5) = dicExtract(ky)
.Columns("B:E").NumberFormatLocal = "[h]:mm"
.Columns("A:E").AutoFit
End With
Next i
End Sub
（半平太） 2026/05/25(月) 17:31:47 (修正 5/26 8:21 Dictionaryは1つでよくなった為）
このとおりばっちりできました。
氏名: ああ
作業: S E
2025/6/9 15:55 21:28
ありがとうございます
簡単に考えてましたが、かなり大変なことがわかりました
思い込みから、週単位にブックにしないとと思っていましたが、ラベルを工夫すれば大丈夫なことなど勉強になりました
本当にありがとうございました
（pc00） 2026/05/26(火) 09:40:57
最初、考えていたテンプレート用意してそれに書き込むのは
関数のなら思いつくのですが、
VBAでするのは高度なことがわかりました今後勉強していきます
（pc00） 2026/05/26(火) 09:51:01
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.