編集履歴

回答編集履歴

使わないかもだけど4/2追加分一部修正しました

2020/04/03 10:39

投稿

スコア52

test CHANGED Viewed

@@ -402,6 +402,8 @@
     ws.Activate
+    Set rr = d.Areas(1).Offset(, -1)
     For Each r1 In d.Areas
         r1.Value = r1.Value
@@ -414,7 +416,7 @@
             If IsNumeric(y) Then
-                r1(y).Value = r1(y).Value & "｜" & r2.Offset(, 1).Value
+                r1(y).Value = CStr(r1(y).Value) & "｜" & r2.Offset(, 1).Value
             End If

サンプル追加

2020/04/03 10:39

投稿

end-u

スコア52

test CHANGED Viewed

@@ -191,3 +191,249 @@
 End Sub
 ```
+（2020.04.02追加）
+..なんか自分でも納得いかないコードですが..
+すみません、「こんなアプローチもあります」的なサンプル扱いでお願いします
+```VBA
+Sub test2()
+    Dim r  As Range
+    Dim d  As Range
+    Dim dd As Range
+    Dim cc As Range
+    Dim rr As Range
+    Dim x  As Long
+    Dim i  As Long
+    Dim j  As Long
+    Dim k  As Long
+    '予定表の範囲を取得
+    With Sheets("予定表")
+        Set r = .Range("A2").CurrentRegion
+        Set dd = .Range("B3", r(r.Count))
+    End With
+    Set cc = dd.Resize(1).Offset(-1)
+    Set rr = dd.Resize(, 1).Offset(, -1)
+    Dim pt As PivotTable
+    Dim st As String
+    Dim ws As Worksheet
+    Set ws = Sheets.Add
+    With Sheets("日報")
+        x = .Cells(.Rows.Count, 10).End(xlUp).Row
+        k = x + 1 '最後のデータクリアで使う
+        '日報から氏名、日付、略号場所キーでピボット作成 _
+         後で日報ベースの予定｜実績の実績データ追加で使う
+        Set r = .Range("A1", .Cells(x, "L"))
+        r.Columns("L").Formula = "=B1&H1"
+        st = .Range("L1").Value
+        Set pt = ActiveWorkbook.PivotCaches.Add( _
+                                SourceType:=xlDatabase, _
+                                SourceData:=r) _
+                                .CreatePivotTable(ws.Range("A1"))
+        pt.ColumnGrand = False
+        pt.RowGrand = False
+        pt.RowAxisLayout xlTabularRow
+        With pt.PivotFields("氏名")
+            .Orientation = xlRowField
+            .Subtotals(1) = False
+        End With
+        With pt.PivotFields("日付")
+            .Orientation = xlRowField
+            .Subtotals(1) = False
+        End With
+        pt.PivotFields(st).Orientation = xlRowField
+        pt.AddDataField pt.PivotFields("執務時間"), "執務時間計", xlSum
+        '予定表の氏名と日付を日報に追加
+        x = x + 1
+        For i = 1 To rr.Count
+            For j = 1 To cc.Count
+                If dd(i, j).Value <> "" Then
+                    .Cells(x, "D").Value = rr(i).Value
+                    .Cells(x, "J").Value = cc(j).Value
+                    x = x + 1
+                End If
+            Next
+        Next
+        Set r = .Range("A1", .Cells(x - 1, "L"))
+    End With
+    'ピボット利用して「結合」シート作成
+    Dim ws2 As Worksheet
+    Set ws2 = Sheets.Add
+    With ActiveWorkbook.PivotCaches.Add( _
+                        SourceType:=xlDatabase, _
+                        SourceData:=r) _
+                        .CreatePivotTable(ws2.Range("A1"))
+        .ColumnGrand = False
+        .RowGrand = False
+        .RowAxisLayout xlTabularRow
+        .PivotFields("日付").Orientation = xlRowField
+        .PivotFields("氏名").Orientation = xlColumnField
+        .AddDataField .PivotFields("略号"), "予定｜実績", xlCount
+        .AddDataField .PivotFields("執務時間"), "執務時間計", xlSum
+        .DataPivotField.Orientation = xlColumnField
+        '"予定｜実績"の範囲取得
+        .PivotSelect "予定｜実績", xlDataOnly
+        Set d = Selection
+        'PivotTableを解除
+        .TableRange2.Copy
+        .TableRange2.PasteSpecial xlPasteValues
+    End With
+    Application.CutCopyMode = False
+    '予定表から予定｜実績データ追加 _
+     数式文字列設定 =INDEX(dd,MATCH($A4,rr,0),MATCH(B$2,cc,0))&""
+    Dim s(2) As String
+    s(0) = "=index(" & dd.Address(, , , True)
+    s(1) = "match($A4," & rr.Address(, , , True) & ",0)"
+    s(2) = "match(B$2," & cc.Address(, , , True) & ",0))&"""""
+    d.Formula = Join(s, ",")
+    '日報ベースの予定｜実績の実績データ追加
+    Dim r1 As Range
+    Dim r2 As Range
+    Dim y
+    ws.Activate
+    For Each r1 In d.Areas
+        r1.Value = r1.Value
+        pt.PivotSelect r1(1).Offset(-2).Value, xlLabelOnly
+        For Each r2 In Selection.Offset(, 1)
+            y = Application.Match(CLng(r2.Value), rr, 0)
+            If IsNumeric(y) Then
+                r1(y).Value = r1(y).Value & "｜" & r2.Offset(, 1).Value
+            End If
+        Next
+    Next
+    '追加したダミーデータと作業用Sheetをクリア
+    r.Columns("L").ClearContents
+    Range(r(k, 1), r(r.Count)).ClearContents
+    Application.DisplayAlerts = False
+    ws.Delete
+    Application.DisplayAlerts = True
+End Sub
+```

別案

2020/04/02 14:13

投稿

end-u

スコア52

test CHANGED Viewed

@@ -73,3 +73,121 @@
 修正後の式を下方向と各氏名の後に挿入した列にコピーすると良いです
 必要に応じて要所要所をマクロ化すれば良いでしょう
+（追記）
+ぁ一応、逆に日報ベースの別案も作ってはいましたけどね
+ピボットをベースに予定表の内容がMatchするものをひっぱってくる感じ。
+提示のレイアウト限定ではありますが
+```VBA
+Sub test()
+    Dim r  As Range
+    Dim d  As Range
+    Dim dd As Range
+    Dim cc As Range
+    Dim rr As Range
+    With Sheets("日報")
+        'PivotTableのSourceData
+        Set r = .Range("K1", .Cells(.Rows.Count, 4).End(xlUp).Offset(, -3))
+    End With
+    'とりあえず新規Sheetに集計してみる
+    With ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, _
+                                        SourceData:=r).CreatePivotTable("")
+        .PivotFields("日付").Orientation = xlRowField
+        .PivotFields("氏名").Orientation = xlColumnField
+        '"略号"の集計はダミー。後で数式セット
+        .AddDataField .PivotFields("略号"), "略号&場所", xlCount
+        .AddDataField .PivotFields("執務時間"), "執務時間計", xlSum
+        .DataPivotField.Orientation = xlColumnField
+        .ColumnGrand = False
+        .RowGrand = False
+        .RowAxisLayout xlTabularRow
+        '"略号&場所"の範囲取得
+        .PivotSelect "'略号&場所'", xlDataOnly
+        Set d = Selection
+        .TableRange2.Copy
+        'PivotTableを解除
+        .TableRange2.PasteSpecial xlPasteValues
+    End With
+    Application.CutCopyMode = False
+    '数式の参照先アドレスget
+    With Sheets("予定表")
+        Set r = .Range("A2").CurrentRegion
+        Set dd = .Range("B3", r(r.Count))
+    End With
+    Set cc = dd.Resize(1).Offset(-1)
+    Set rr = dd.Resize(, 1).Offset(, -1)
+    '数式文字列設定 =INDEX(dd,MATCH($A4,rr,0),MATCH(B$2,cc,0))&""
+    Dim s(2) As String
+    s(0) = "=index(" & dd.Address(, , , True)
+    s(1) = "match($A4," & rr.Address(, , , True) & ",0)"
+    s(2) = "match(B$2," & cc.Address(, , , True) & ",0))&"""""
+    d.Formula = Join(s, ",")
+    '数式の値化が必要であれば以下コメント活かす
+    'For Each r In d.Areas
+    '    r.Value = r.Value
+    'Next
+End Sub
+```