質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

87.96%

データを表に変換して集計

解決済

回答 1

投稿 編集

  • 評価
  • クリップ 0
  • VIEW 1,091

score 14

前提・実現したいこと

勤怠データを表に変換して、集計を行います。

色々調べ、試行錯誤して作成しましたが1)~10)をまとめてコードにする能力がありませんので、それぞれのコードをCallでつないで作成しております。

1)シート執務日報のデータをシート結果にコピーする
2)シート結果のH列(場所)を頭文字(1字)のみにする
3)シート結果のJ列(氏名)を苗字のみにする
4)シート結果のJ列の人をシート仕様書のC4~(下に)に重複しないリストを作成する
5)シート表にシート結果を基にD列(日付)、E列(大項目)、H列(場所)、J列(氏名)で集計した表を作成する
6)シート仕様書のC4~をリストで並べ替える(手動)
7)6)を基にシート表を並べ替える
8)シート仕様書のJ3~J8をシート表の最終行より1行空けたA列に貼り付ける(未了)
9)シート表に8)の場所毎に人毎に集計する(未完成)
10)シート表の列幅を揃える(未了)

シート執務日報のK列は小数点があります

問題点

① 4)にエラーが出ます。
先月まではエラーはありませんでした。
何が原因か分かりません。

実行時エラー1004
アプリケーション定義またはオブジェクト定義のエラーです。
.Add Type:=xlValidateList, _
                AlertStyle:=xlValidAlertStop, _
                Operator:=xlBetween, _
                Formula1:="=名前リスト"

② 処理時間が長いです。
可能であれば、もう少し短くしたいです。

③ 8)と10)は未了です

④ 9)は未完成です

その他、コードの書き方でおかしい箇所等ありましたらご指導いただけないでしょうか?
よろしくお願いいたします。

該当のソースコード

1)

Option Explicit
 Sub 結果へコピー()

    Dim myFrmSht As Worksheet
    Dim myToSht As Worksheet
    Dim myCell As Rang

    Set myFrmSht = Worksheets("執務日報")
    Set myToSht = Worksheets("結果")

    For Each myCell In myFrmSht.Range("A1").CurrentRegion
        If Len(myCell.Value) = 0 Then
            myCell.Value = "他"
        End If
    Next

    myToSht.Cells.Clear

    myFrmSht.Range("A1").CurrentRegion.Copy myToSht.Range("A1")
    myToSht.Range("A1").CurrentRegion.EntireColumn.AutoFit

    myToSht.Range("A1").CurrentRegion.RemoveDuplicates Columns:=Array(4, 5, 8, 10), _
        Header:=xlNo

     With myToSht.Range("A1").CurrentRegion
        With .Offset(1, 10).Resize(.Rows.Count - 1, 1)
            .FormulaR1C1 = _
            "=SUMIFS(執務日報!C,執務日報!C[-7],RC[-7],執務日報!C[-6],RC[-6],執務日報!C[-3],RC[-3],執務日報!C[-1],RC[-1])"
            .Value = .Value
        End With
    End With

 End Sub


2)

Sub 苗字のみに変更()

    Dim i As Integer
    Dim v
    Dim s
    Dim a
    Dim r  As Range

    Set a = Worksheets("結果")

    For i = 2 To a.Cells(Rows.Count, "J").End(xlUp).Row

    Set r = a.Cells(i, "J")

    s = r.Value
    v = Split(s, " ")

    r.Offset(0, 0).Value = v(0)

     Next i

 End Sub


3)

Option Explicit
Sub 場所を略称に変更()

        Dim i As Integer
        Dim a

       Set a = Worksheets("結果")

        For i = 2 To a.Cells(Rows.Count, "J").End(xlUp).Row
            a.Cells(i, "H").Value = Left(a.Cells(i, "H").Value, 1)
        Next i

    End Sub


4)

Sub 名前リストを作成()

Dim a As Worksheet, b As Worksheet

    Set a = Worksheets("結果")
    Set b = Worksheets("仕様書")

    With a
        With .Range(.Range("J1"), .Cells(.Rows.Count, "J").End(xlUp))
            b.Range("P1").Resize(.Rows.Count, 1).Value = .Value
        End With
    End With

    With b
        With .Range(.Range("P1"), .Cells(.Rows.Count, "P").End(xlUp))
            .RemoveDuplicates Columns:=1, Header:=xlNo
        End With
    End With

    With b.Columns("C:C")
        With .Validation
            .Delete
            .Add Type:=xlValidateList, _
                AlertStyle:=xlValidAlertStop, _
                Operator:=xlBetween, _
                Formula1:="=名前リスト"
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .IMEMode = xlIMEModeNoControl
            .ShowInput = True
            .ShowError = True
        End With
    End With
End Sub


5)

Public Sub 結果を表へ出力()
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim Cnt As Long
    Dim lr As Long
    Dim Aary() As Variant
    Dim Mary() As Variant
    Dim Dm As Object
    Dim Mm As Object
    Dim Var As Variant
    Dim Base As Variant

    If ExistsWorkSheet("表") = True Then
        Application.DisplayAlerts = False
        Worksheets("表").Delete
        Application.DisplayAlerts = True
    End If

    Set Dm = CreateObject("Scripting.Dictionary")
    Set Mm = CreateObject("Scripting.Dictionary")
    With Worksheets("結果")
        lr = .Cells(.Rows.Count, 4).End(xlUp).Row
        Base = Intersect(.Range("D:K"), .Range(.Rows(2), .Rows(lr)))
        .Copy after:=Worksheets(Worksheets.Count)
    End With
    Worksheets(Worksheets.Count).Name = "表"
    For i = 1 To UBound(Base, 1)
        Dm(Base(i, 1)) = Empty
        Mm(Base(i, 7)) = Empty
    Next
    Mary = Mm.keys
    ReDim Aary(1 To Dm.Count, 1 To Mm.Count + 1)
    For i = 1 To UBound(Base, 1)
        For Each Var In Dm
            Cnt = Cnt + 1
            If Var = Base(i, 1) Then
                Aary(Cnt, 1) = Var
                For k = 0 To UBound(Mary)
                    If Base(i, 7) = Mary(k) Then
                        Aary(Cnt, k + 2) = Aary(Cnt, k + 2) & Base(i, 5) & Base(i, 8) & " "
                    End If
                Next
            End If
        Next
        Cnt = 0
    Next
    Worksheets("?\").Activate
    With ActiveSheet
        .UsedRange.Clear
        .Cells(1, 2).Resize(, UBound(Mary) + 1) = Mary
        .Cells(2, 1).Resize(UBound(Aary, 1), UBound(Aary, 2)) = Aary
        .UsedRange.EntireColumn.AutoFit
        .UsedRange.Borders.LineStyle = xlContinuous
        .Range("A:A").SpecialCells(2).NumberFormatLocal = "yyyy/mm/dd"
    End With
    Set Dm = Nothing
    Set Mm = Nothing
    Erase Base, Aary, Mary
End Sub

Public Function ExistsWorkSheet(ByVal sheetName As String) As Boolean
    Dim ws As Worksheet
    ExistsWorkSheet = False
    For Each ws In Worksheets
        If UCase(ws.Name) = UCase(sheetName) Then
            ExistsWorkSheet = True
            Exit Function
        End If
    Next ws
End Function


7)

Public Sub 仕様書の名前順に並べ替え()
    Dim ws As Worksheet
    Dim ms As Worksheet
    Dim mscp As Worksheet
    Dim dicM As Object  
    Dim dicW As Object  
    Dim maxrowM As Long
    Dim maxrowW As Long
    Dim maxcolW As Long
    Dim wrow As Long
    Dim wcol As Long
    Dim set_col As Long
    Dim set_row As Long
    Dim key As Variant
    Dim Warr As Variant
    Set ws = Worksheets("表")
    Set ms = Worksheets("仕様書")
    Set dicM = CreateObject("Scripting.Dictionary")
    Set dicW = CreateObject("Scripting.Dictionary")
    maxrowM = ms.Cells(Rows.Count, "C").End(xlUp).Row
    maxrowW = ws.Cells(Rows.Count, "A").End(xlUp).Row 
    maxcolW = ws.Cells(1, Columns.Count).End(xlToLeft).Column  

    If maxrowM < 4 Then Exit Sub
    If maxrowW < 2 Then Exit Sub
    If maxcolW < 2 Then Exit Sub

    For wrow = 4 To maxrowM
        key = ms.Cells(wrow, "C").Value
        dicM(key) = True
    Next

    For wcol = 2 To maxcolW
        key = ws.Cells(1, wcol).Value
        If dicM.exists(key) = False Then
            MsgBox ("仕様書" & key & "なし")
            Exit Sub
        End If
        dicW(key) = wcol
    Next

    Warr = ws.Range(ws.Cells(1, 1), ws.Cells(maxrowW, maxcolW)).Value

    ms.Copy after:=Worksheets(Worksheets.Count)
    Set mscp = Worksheets(Worksheets.Count)
    mscp.Range("B4:" & "C" & maxrowM).Sort key1:=Range("B4"), order1:=xlAscending
    set_col = 2
    For wrow = 4 To maxrowM
        key = mscp.Cells(wrow, "C").Value
        If dicW.exists(key) = True Then
            For set_row = 1 To maxrowW
                ws.Cells(set_row, set_col).Value = Warr(set_row, dicW(key))
            Next
            set_col = set_col + 1
        End If
    Next

    Application.DisplayAlerts = False
    mscp.Delete
    Application.DisplayAlerts = True
    MsgBox ("並べ替え完了")
End Sub


9)

Sub 表を集計する()
    Dim c As Range

    For Each c In Range("A:A").SpecialCells(2)
        If c.Value = "本社" Or c.Value = "事務所" Or c.Value = "子会社" Or c.Value = "支店・営業所" Or c.Value = "その他" Or c.Value = "合計" Then c.Offset(, 1).Resize(, 2).ClearContents
    Next c
    For Each c In Range("B:Q").SpecialCells(2)
        Call subx(c.Value, c.Column)
    Next c
End Sub

Function subx(arg1, arg2)
    Dim i As Long, rw As Long
    For i = 1 To Len(arg1)

        If Mid(arg1, i, 1) = "本" Or Mid(arg1, i, 1) = "事" Or Mid(arg1, i, 1) = "子" Or Mid(arg1, i, 1) = "支" Or Mid(arg1, i, 1) = "他" Then
        rw = Range("A:A").Find(Mid(arg1, i, 1), , , xlPart).Row
        Cells(rw, arg2).Value = Val(Cells(rw, arg2).Value) + Val(Mid(arg1, i + 1))
        rw = Range("A:A").Find("???v", , , xlWhole).Row
        Cells(rw, arg2).Value = Val(Cells(rw, arg2).Value) + Val(Mid(arg1, i + 1))
        End If

    Next i
End Function

様式

◆執務日報
イメージ説明

◆結果
イメージ説明

◆表
イメージ説明

ピポッドテーブル

イメージ説明

  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 過去に投稿した質問と同じ内容の質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

回答 1

checkベストアンサー

+2

例えば、
自ブック(マクロを仕込むブック)に、
日報
集計表
作業用
の3つのシートがあるとします。
そして日報シートに、

  日付        場所          氏名        執務時間  

    2020.7.1  事務所        織田 信長         7  

    2020.7.5  事務所        明智 光秀       2.5  

    2020.7.9  本社          織田 信長       3.5  

   2020.7.13  本社          千 利休           1  

   2020.7.17  本社          徳川 家康         5  

   2020.7.21  子会社        武田 信玄         7  

   2020.7.25  支店・営業所  織田 信長       2.5  

   2020.7.29  事務所        明智 光秀       3.5  

    2020.8.2  事務所        織田 信長         1  

    2020.8.6  事務所        千 利休           5  

   2020.8.10  本社          徳川 家康         7  

   2020.8.14  本社          武田 信玄       2.5  

   2020.8.18  本社          織田 信長       3.5  

   2020.8.22  子会社        明智 光秀         1  

   2020.8.26  支店・営業所  織田 信長         5  

   2020.8.30  本社          千 利休           7  

    2020.9.3  子会社        徳川 家康       2.5  

    2020.9.7  支店・営業所  武田 信玄       3.5  

というようなデータがあるとして、

以下のようなコードで、
自分好みの表(そちらの希望に沿ってはいません。)を作ることが可能です。
あとの表示の順番や、列の具合、抽出したい月とかはそちらの希望するよう加工編集してください。

他人が書いたコードは解読するのに苦労するとは思いますが、
参考になれば。

参考サイト>>
構造化プログラミングに挑戦しよう!
仕様要件からコードの組み立てを考える。

他にもいいサイトがある気がします。
探してみてください。

※文字数制限に引っかかったため、一部削除しました。

コードを修正しました。
コンパイルはしてみましたが、
動作確認はしてません。
参考になれば。

'ピボットテーブルを使った集計サンプル Ver.0.90
Option Explicit

Sub メイン()
    Dim wshData As Worksheet
    Dim wshResult As Worksheet

    Set wshData = Worksheets("日報")
    Set wshResult = Worksheets("集計")
    集計 wshData, wshResult, "日付", "氏名,場所"
    集計 wshData, wshResult, "場所", "氏名", False
End Sub

Private Sub 集計( _
        ByRef wshOld As Worksheet, _
        ByRef wshNew As Worksheet, _
        ByVal strSideItem As String, _
        ByVal strTopItem As String, _
        Optional ByVal flg As Boolean = True)
    Dim rngTopleft As Range
    Dim pvtMyTable As PivotTable

    'ピボットテーブルで集計
    Set pvtMyTable = GetResult(wshOld, strSideItem, strTopItem)
    '書き出し位置の取得
    Set rngTopleft = GetTopLeft(wshNew, flg)
    '集計結果を様式に沿って出力
    ResultOutput pvtMyTable, rngTopleft, flg
End Sub

'ピボットテーブルで集計
Private Function GetResult( _
        ByRef wshSource As Worksheet, _
        ByVal strSideItem As String, _
        ByVal strTopItem As String) As PivotTable
    Dim pvtCache As PivotCache
    Dim pvtTable As PivotTable
    Dim f As PivotField
    Dim rngSourceData As Range
    Dim rngWorkCellRange As Range
    Dim v As Variant
    Dim wsh As Workbook

    'セル範囲、ピボットテーブルの取得
    Set wsh = ThisWorkbook.Worksheets("作業用")
    Set rngSourceData = wshSource.UsedRange
    On Error GoTo ErrHandler
    Set pvtTable = wsh.PivotTables(1)
    On Error GoTo 0

    'ピボットテーブルでの集計
    With pvtTable
        '初期化
        .ClearTable
        '項目の配置
        .PivotFields(strSideItem).Orientation = xlRowField
        For Each v In Split(strTopItem, ",")
            .PivotFields(v).Orientation = xlColumnField
        Next
        .AddDataField .PivotFields("執務時間")
        '小計行の非表示化
        For Each f In .PivotFields
            f.Subtotals(1) = False
        Next
    End With

    '返り値のセット
    Set GetResult = pvtTable

    Exit Function

    'エラー回避処理(ピボットテーブルがシート上に未作成の場合は新規に作成)
ErrHandler:
    Set pvtCache = wsh.Parent.PivotCaches.Create( _
                   SourceType:=xlDatabase, _
                   SourceData:=rngSourceData)
    Set rngWorkCellRange = wsh.Range("A1")
    Set pvtTable = pvtCache.CreatePivotTable(TableDestination:=rngWorkCellRange)
    Resume Next
End Function

'書出し位置の取得
Private Function GetTopLeft( _
        ByRef wsh As Worksheet, _
        ByVal flg As Boolean) As Range
    Dim c As Range

    With wsh.UsedRange
        If flg Then
            .Clear
            Set c = .Cells(1)
        Else
            Set c = .Cells(Rows.Count + 1, 1)
        End If
    End With
    Set GetTopLeft = c
End Function

'集計結果を様式に沿って出力
Private Sub ResultOutput( _
        ByRef pvtTable As PivotTable, _
        ByRef rngCopyTo As Range, _
        ByVal flg As Boolean)

    '表頭の作成
    If flg Then
        Set表頭 pvtTable.TableRange1.Rows(2), rngCopyTo
    End If
    '表側の作成
    Set表側 pvtTable.RowRange, rngCopyTo.Offset(1)
    '表体の作成
    Set表体 pvtTable.DataBodyRange, rngCopyTo.Offset(1, 1), flg

    '列幅をオートフィット
    rngCopyTo.CurrentRegion.EntireColumn.AutoFit
End Sub

'*******************************************
'表頭の作成
'第一引数 rngFrom:転記元のセル範囲(Range)
'第二引数 rngTo:転記先のセル範囲(Range)
'******************************************
Private Sub Set表頭(ByRef rngFrom As Range, ByRef rngTo As Range)
    Dim v As Variant
    Dim ix As Long

    '元のセル範囲の値を一次配列で取得
    '(ワークシート上の関数はセル範囲を与える仕様だが、
    '配列も受け取れる関数があるので値(Value)を与えてもよい。)
    With WorksheetFunction
        v = .Transpose(.Transpose(rngFrom.Cells))
    End With

    'それぞれの値の加工
    For ix = LBound(v) To UBound(v)
        If ix = 1 Then
            v(ix) = "日付"
        Else
            '空白でないなら
            If Len(v(ix)) > 0 Then
                'スペース文字で文字列を分割し最初の値を再設定
                v(ix) = Split(v(ix), " ")(0)
            End If
        End If
    Next
    'シート上へ転記
    With rngTo.Resize(, rngFrom.Columns.Count)
        .Value = v
        '選択範囲内で中央に配置の設定
        .HorizontalAlignment = xlCenterAcrossSelection
    End With
End Sub

'******************************
'表側の作成
'***********************
Private Sub Set表側(ByRef rngFrom As Range, ByRef rngTo As Range)
    rngTo.Resize(rngFrom.Rows.Count - 1).Value = rngFrom.Offset(1).Value
End Sub

'**********************************
'表体の作成
'第一引数 rngFrom:転記元セル範囲(Range)
'第二引数 rngTo:転記先セル範囲(Range)
'第三引数 flg:データに項目(略称)を付加するかどうかのフラグ(Boolean)
'*************************************
Private Sub Set表体(ByRef rngFrom As Range, _
                  ByRef rngTo As Range, _
                  ByVal flg As Boolean)
    Dim vv As Variant
    Dim v As Variant
    Dim ixH As Long
    Dim ixV As Long

    '値を2次元配列変数で取得
    vv = rngFrom.Value
    '略称の付加
    If flg Then
        '略称の元を一次配列で取得
        With WorksheetFunction
            v = .Transpose(.Transpose(rngFrom.Rows(0).Cells))
        End With
        'それぞれの値を巡回し、値に略称をくっつけていく
        For ixH = LBound(vv, 1) To UBound(vv, 1)
            For ixV = LBound(vv, 2) To UBound(vv, 2)
                If IsEmpty(vv(ixH, ixV)) = False Then
                    vv(ixH, ixV) = Left(v(ixV), 1) & vv(ixH, ixV)
                End If
            Next
        Next
    End If
    '転記先に転記
    rngTo.Resize(rngFrom.Rows.Count, rngFrom.Columns.Count).Value = vv
End Sub


売上集計しているExcelの動作を軽くしたい

↑こちらもピボットテーブルを使った方法を提案しました。参考になれば。

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2020/01/20 20:27

    通常の作成手順に沿って、マクロを作成してました。
    ピポッドの結果をこんな風に用いてマクロを組んでいくとは思いつきませんでした。

    処理時間は一瞬でした。
    コードもスッキリしていて、自分のがごちゃごちゃしていて恥ずかしいです。
    お言葉に甘えて、教えて頂いたコードを参考に加工編集させていただければ幸いです。

    マクロにコメントを入れて下さりありがとうございます。
    まだ分からないコードがあるのですが、もう少し自分で勉強してみようと思います。
    どうしても分からない場合は別途質問しても大丈夫でしょうか。

    キャンセル

  • 2020/01/20 22:35

    どんどん、質問して知識をふやしてください。
    ただ、特定の回答者に負担をかけるような聞き方はやめてくださいね。
    こちらも、パソコンの前に座らない日が多々あるので、回答出来ないこともあるので、過度の期待をされても困ります。
    暇があれば、もうすこしバージョンアップしたいなーとは思ってます。
    こちらも、練習なので、何度か一から書き直すようなことをしています。

    キャンセル

  • 2020/01/24 18:04

    mattumanさん
    色々とありがとうございました。
    時間かかりましたが理解することができました。
    新しいコードも時間かかるかもしれなませんが勉強させて下さい

    また分からない場合は別途質問いたします。

    キャンセル

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 87.96%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

関連した質問

同じタグがついた質問を見る