質問編集履歴

1 ピポッドテーブルの追加

ichigo15

ichigo15 score 14

2020/01/14 20:54  投稿

データを表に変換して集計
### 前提・実現したいこと
勤怠データを表に変換して、集計を行います。
色々調べ、試行錯誤して作成しましたが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
```
### 様式
**◆仕様書**  
![イメージ説明](eebed50d21090e039256cd31a00dd518.png)  
 
**◆執務日報**
![イメージ説明](178a6dba3f18636067248548bc730d72.png)
**◆結果**
![イメージ説明](2d73fce5da330ccb318e033a9126662c.png)
**◆表**
![イメージ説明](b92b16876620baaa877967563941dcfe.png)
![イメージ説明](b0dd490f8dab92a93d7d03613b659f32.png)
### ピポッドテーブル
![イメージ説明](a09341fe88825d23c33c93ba66420fdf.png)
  • VBA

    5024 questions

    VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

  • Excel

    4056 questions

    Excelは、マイクロソフト社が開発しているデータ集計や分析を行う表計算ソフトの一つです。文書作成や表計算、資料作成などの多彩な機能を備えており、統合パッケージであるMicrosoft Officeに含まれています。

  • マクロ

    869 questions

    定義された処理手続きに応じて、どのような一連の処理を行うのかを特定させるルールをマクロと呼びます。

思考するエンジニアのためのQ&Aサイト「teratail」について詳しく知る