回答編集履歴

5 修正

mattuwan

mattuwan score 2007

2020/01/22 19:38  投稿

う~ん。  
なんで、エクセルに備わっている機能で出来ることを、  
自作してるのですか?  
 
「表」と言われている形の「クロス集計表」は、  
「ピボットテーブル」という機能でデータのシートから、  
作成可能です。  
作業用のシートにそれを手動で設定しておけば、  
マクロですることは、  
1)データの参照範囲を再設定  
2)ピボットテーブルの更新  
3)結果を見せるシートにコピペして好みの形に再編集  
ぐらいになると思いますがどうでしょうか?  
 
---  
②について  
上に書きましたが、自作するよりエクセル君が出来ることは、  
エクセル君に任せた方が処理が速い場合が多いです。  
意図が通じて無いようですが、  
事前にピボットテーブルを設定したファイルを配布するのですから、  
ユーザーがピボットテーブルを触ることはありません。  
マクロで自動でやってもらうよう指示するだけです。  
 
③について、  
>1行空けて  
with worksheets("?").usedrange  
   .offset(.rows.count+2).cells(1)  
end with  
 
↑が貼付先のセルになると思います。  
 
>列幅を揃える  
エクセルにまかせていいなら、  
 
worksheets("?").usedrange.entirecolumn.autofit  
 
各列に既定の幅を設定するなら、  
各列毎に設定してください。  
コードはマクロの記録で探ることが可能だと思います。  
 
④について  
ピボットテーブルというのはまさにこういう表を作るための機能なので、  
それを捨てて自分で一から、同じ機能を作るのはナンセンスかなと思いますが、  
関数でも作成可能です。  
表の縦横の項目名を参照して、合計するなら、  
Sumifs関数が使えます。  
[SUMIFS関数で複数の条件を指定して数値を合計す](https://dekiru.net/article/4365/)る  
 
当然マクロで一から作ることも可能ですが、  
処理速度はデータ数が多くなるほど処理が重くなると思います。  
が、全然できないよりは出来た方がいいとおもいます。  
が、テーマがたくさんあると、見る人が何に困っているかわかりずらいので、  
別途質問してはいかがでしょうか?  
 
---  
> ②について教えて頂きたいのですが様式の表のように「場所+時間」を  
> ピポッドで表示するにはどうのようにしたらよいのでしょうか?  
 
「場所」は列ラベルでは?  
 
![イメージ説明](81f8be99e85bd7d6398ec48699266a65.jpeg)  
 
---  
> 表の様式は管理上変更できません。  
>  
> 表の様式をピポッドで作成する方法がありましたら教えて下さい。  
 
う~ん。。。  
ピボットテーブルで集計し、それをご自分の好きなように表示するよう加工することになります。  
 
例えば、
自ブック(マクロを仕込むブック)に、
日報
集計表
作業用
の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 
```
                                                 
というようなデータがあるとして、
以下のようなコードで、
自分好みの表(そちらの希望に沿ってはいません。)を作ることが可能です。
あとの表示の順番や、列の具合、抽出したい月とかはそちらの希望するよう加工編集してください。
他人が書いたコードは解読するのに苦労するとは思いますが、  
参考になれば。  
 
参考サイト>>  
[構造化プログラミングに挑戦しよう!](http://home.att.ne.jp/zeta/gen/excel/c03p06.htm)  
[仕様要件からコードの組み立てを考える。](http://www.asahi-net.or.jp/~ef2o-inue/vba_k/sub04_160.html)  
 
他にもいいサイトがある気がします。  
探してみてください。  
※文字数制限に引っかかったため、一部削除しました。  
---  
コードを修正しました。  
コンパイルはしてみましたが、  
動作確認はしてません。  
参考になれば。  
 
```ExcelVBA
'***********************
'ピボットテーブルを使った自分好みのクロス集計表を作成するサンプル
'作成者:mattuwan
'※著作権は放棄しますです。自己責任で使用・改変してください。
'※エラー回避処理は万全ではないかもしれません。(バグがあるかも?)
'*************************
'ピボットテーブルを使った集計サンプル Ver.0.90
Option Explicit
'********************************
'集計表シートにクロス集計表を2つ作成
'***********************************
Sub Main()
   Dim rngWritingPosition As Range
   Set rngWritingPosition = Worksheets("集計表").Range("A1")
   Get表作成 "日付", "氏名,場所", rngWritingPosition
   With rngWritingPosition.CurrentRegion
       Set rngWritingPosition = .Cells(1).Offset(.Rows.Count)
   End With
   Get表作成 "場所", "氏名", rngWritingPosition, False
End Sub
'*************************************
'表側及び表頭の項目を指定して集計し集計表の指定したセルに結果を挿入
'第一引数 strSideItem:表側に使う項目(String)
'第二引数 strTopItem:表頭に使う項目(複数指定する場合はカンマ区切りで指定)(String)
'第三引数 rngTopLeft:表を作成するセル(左上)の位置を指定(Range)
'第四引数 flg:表を作成するときにシートの初期化を行うか否かのフラグ(boolean)
'返り値:作成した表のセル範囲
'***********************************:
Private Function Get表作成(ByVal strSideItem As String, _
                       ByVal strTopItem As String, _
                       ByRef rngTopLeft As Range, _
                       Optional ByVal flg As Boolean = True) As Range
   Dim pvtTable As PivotTable
   'シートの初期化
   If flg Then
       rngTopLeft.Worksheet.UsedRange.Clear
   End If
   
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 pvtTable = GetPvt集計(strSideItem, strTopItem)
   
   '集計結果を編集して集計用シートに集計表を作成
   Set集計表シートへ転記 rngTopLeft, pvtTable, flg
   '返り値のセット
   Set Get表作成 = rngTopLeft.CurrentRegion
End Function
'*********************************
   Set pvtMyTable = GetResult(wshOld, strSideItem, strTopItem)
   '書き出し位置の取得
   Set rngTopleft = GetTopLeft(wshNew, flg)
   '集計結果を様式に沿って出力
   ResultOutput pvtMyTable, rngTopleft, flg
End Sub
'ピボットテーブルで集計
'第一引数 strSideItem:表側の項目(String)
'第二引数 strTopItem:表頭の項目(string)
'返り値:設定したピボットテーブル
'*****************************************
Private Function GetPvt集計(ByVal strSideItem As String, _
                         ByVal strTopItem As String) As PivotTable
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 wbk As Workbook
   Dim wsh As Workbook
   'セル範囲、ピボットテーブルの取得
   Set wbk = ThisWorkbook
   Set rngSourceData = wbk.Worksheets("日報").Range("A1").CurrentRegion
   Set wsh = ThisWorkbook.Worksheets("作業用")
   Set rngSourceData = wshSource.UsedRange
   On Error GoTo ErrHandler
   Set pvtTable = wbk.Worksheets("作業用").PivotTables(1)
   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  
   
   '返り値のセット  
   Set GetPvt集計 = pvtTable  
   Exit Function
'エラー回避処理(ピボットテーブルがシート上に未作成の場合は新規に作成)
   'エラー回避処理(ピボットテーブルがシート上に未作成の場合は新規に作成)
ErrHandler:
   Set pvtCache = wbk.PivotCaches.Create( _
   Set pvtCache = wsh.Parent.PivotCaches.Create( _
                  SourceType:=xlDatabase, _
                  SourceData:=rngSourceData)
   Set rngWorkCellRange = wbk.Worksheets("作業用").Range("A1")
   Set rngWorkCellRange = wsh.Range("A1")
   Set pvtTable = pvtCache.CreatePivotTable(TableDestination:=rngWorkCellRange)
   Resume Next
End Function
'**************************************
'ピボットテーブルでの集計結果を編集して集計表シートに集計表を作成
'第一引数 rngCopyTo:作成するセルの位置(左上)(Range)
'第二引数 pvtCopyFrom:集計表の元となるピボットテーブル(PivotTable)
'第三引数 flg:シートを初期化したかどうかのフラグ、初期化されない場合は表頭を標記しない(Boolean)
'***************************************
Private Sub Set集計表シートへ転記(ByRef rngCopyTo As Range, _
                        ByRef pvtCopyFrom As PivotTable, _
                        ByVal flg As Boolean)
'書出し位置の取得
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表頭 pvtCopyFrom.TableRange1.Rows(2), rngCopyTo
       Set表頭 pvtTable.TableRange1.Rows(2), rngCopyTo
   End If
   '表側の作成
   Set表側 pvtCopyFrom.RowRange, rngCopyTo.Offset(1)
   Set表側 pvtTable.RowRange, rngCopyTo.Offset(1)
   '表体の作成
   Set表体 pvtCopyFrom.DataBodyRange, rngCopyTo.Offset(1, 1), flg
   
   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
 
'****************<プログラム終わり>***************************  
```
時間がありそうなのでコメントを入れてみました。
他人が書いたコードは解読するのに苦労するとは思いますが、
参考になれば。
参考サイト>>
[構造化プログラミングに挑戦しよう!](http://home.att.ne.jp/zeta/gen/excel/c03p06.htm)
[仕様要件からコードの組み立てを考える。](http://www.asahi-net.or.jp/~ef2o-inue/vba_k/sub04_160.html)
他にもいいサイトがある気がします。
探してみてください。
※文字数制限に引っかかったため、一部削除しました。
[売上集計しているExcelの動作を軽くしたい](https://teratail.com/questions/236682)
↑こちらもピボットテーブルを使った方法を提案しました。参考になれば。
4 追記

mattuwan

mattuwan score 2007

2020/01/18 18:25  投稿

う~ん。
なんで、エクセルに備わっている機能で出来ることを、
自作してるのですか?
「表」と言われている形の「クロス集計表」は、
「ピボットテーブル」という機能でデータのシートから、
作成可能です。
作業用のシートにそれを手動で設定しておけば、
マクロですることは、
1)データの参照範囲を再設定
2)ピボットテーブルの更新
3)結果を見せるシートにコピペして好みの形に再編集
ぐらいになると思いますがどうでしょうか?
---
 
> ① 4)にエラーが出ます。  
> 先月まではエラーはありませんでした。  
> 何が原因か分かりません。  
>  
>  
> 実行時エラー1004  
> アプリケーション定義またはオブジェクト定義のエラーです。  
>  
> .Add Type:=xlValidateList, _  
>                AlertStyle:=xlValidAlertStop, _  
>                Operator:=xlBetween, _  
>                Formula1:="=名前リスト"  
 
名前リストという名前の定義を消したのでは?  
オブジェクト定義というのは、  
今回の場合、指定されたセル範囲(=Rangeオブジェクトと呼ぶ)が存在しない場合によく出ます。  
 
②について
上に書きましたが、自作するよりエクセル君が出来ることは、
エクセル君に任せた方が処理が速い場合が多いです。
意図が通じて無いようですが、
事前にピボットテーブルを設定したファイルを配布するのですから、
ユーザーがピボットテーブルを触ることはありません。
マクロで自動でやってもらうよう指示するだけです。
③について、
>1行空けて
with worksheets("?").usedrange
   .offset(.rows.count+2).cells(1)
end with
↑が貼付先のセルになると思います。
>列幅を揃える
エクセルにまかせていいなら、
worksheets("?").usedrange.entirecolumn.autofit
各列に既定の幅を設定するなら、
各列毎に設定してください。
コードはマクロの記録で探ることが可能だと思います。
④について
ピボットテーブルというのはまさにこういう表を作るための機能なので、
それを捨てて自分で一から、同じ機能を作るのはナンセンスかなと思いますが、
関数でも作成可能です。
表の縦横の項目名を参照して、合計するなら、
Sumifs関数が使えます。
[SUMIFS関数で複数の条件を指定して数値を合計す](https://dekiru.net/article/4365/)る
当然マクロで一から作ることも可能ですが、
処理速度はデータ数が多くなるほど処理が重くなると思います。
が、全然できないよりは出来た方がいいとおもいます。
が、テーマがたくさんあると、見る人が何に困っているかわかりずらいので、
別途質問してはいかがでしょうか?
---
> ②について教えて頂きたいのですが様式の表のように「場所+時間」を
> ピポッドで表示するにはどうのようにしたらよいのでしょうか?
「場所」は列ラベルでは?
![イメージ説明](81f8be99e85bd7d6398ec48699266a65.jpeg)
---
> 表の様式は管理上変更できません。
>
> 表の様式をピポッドで作成する方法がありましたら教えて下さい。
う~ん。。。
ピボットテーブルで集計し、それをご自分の好きなように表示するよう加工することになります。
例えば、
自ブック(マクロを仕込むブック)に、
日報
集計表
作業用
の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 
```
                                                 
というようなデータがあるとして、
以下のようなコードで、
自分好みの表(そちらの希望に沿ってはいません。)を作ることが可能です。
あとの表示の順番や、列の具合、抽出したい月とかはそちらの希望するよう加工編集してください。
```ExcelVBA
'***********************  
'ピボットテーブルを使った自分好みのクロス集計表を作成するサンプル  
'作成者:mattuwan  
'※著作権は放棄しますです。自己責任で使用・改変してください。  
'※エラー回避処理は万全ではないかもしれません。(バグがあるかも?)  
'*************************  
Option Explicit
'********************************  
'集計表シートにクロス集計表を2つ作成  
'***********************************  
Sub Main()
   Dim rngWritingPosition As Range
   Set rngWritingPosition = Worksheets("集計表").Range("A1")
   Get表作成 "日付", "氏名,場所", rngWritingPosition
   With rngWritingPosition.CurrentRegion
       Set rngWritingPosition = .Cells(1).Offset(.Rows.Count)
   End With
   Get表作成 "場所", "氏名", rngWritingPosition, False
End Sub
'*************************************  
'表側及び表頭の項目を指定して集計し集計表の指定したセルに結果を挿入  
'第一引数 strSideItem:表側に使う項目(String)  
'第二引数 strTopItem:表頭に使う項目(複数指定する場合はカンマ区切りで指定)(String)  
'第三引数 rngTopLeft:表を作成するセル(左上)の位置を指定(Range)  
'第四引数 flg:表を作成するときにシートの初期化を行うか否かのフラグ(boolean)  
'返り値:作成した表のセル範囲  
'***********************************:  
Private Function Get表作成(ByVal strSideItem As String, _
                       ByVal strTopItem As String, _
                       ByRef rngTopLeft As Range, _
                       Optional flg As Boolean = True) As Range
                       Optional ByVal flg As Boolean = True) As Range
   Dim pvtTable As PivotTable
   'シートの初期化  
   If flg Then
       rngTopLeft.Worksheet.UsedRange.Clear
   End If
   
   'ピボットテーブルで集計
   Set pvtTable = GetPvt集計(strSideItem, strTopItem)
     
   '集計結果を編集して集計用シートに集計表を作成  
   Set集計表シートへ転記 rngTopLeft, pvtTable, flg
   '返り値のセット  
   Set Get表作成 = rngTopLeft.CurrentRegion
End Function
'*********************************  
'ピボットテーブルで集計  
'第一引数 strSideItem:表側の項目(String)  
'第二引数 strTopItem:表頭の項目(string)  
'返り値:設定したピボットテーブル  
'*****************************************  
Private Function GetPvt集計(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 wbk As Workbook
   'セル範囲、ピボットテーブルの取得  
   Set wbk = ThisWorkbook
   Set rngSourceData = wbk.Worksheets("日報").Range("A1").CurrentRegion
   On Error GoTo ErrHandler
   Set pvtTable = wbk.Worksheets("作業用").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 GetPvt集計 = pvtTable
   Exit Function
'エラー回避処理(ピボットテーブルがシート上に未作成の場合は新規に作成)  
ErrHandler:
   Set pvtCache = wbk.PivotCaches.Create( _
                  SourceType:=xlDatabase, _
                  SourceData:=rngSourceData)
   Set rngWorkCellRange = wbk.Worksheets("作業用").Range("A1")
   Set pvtTable = pvtCache.CreatePivotTable(TableDestination:=rngWorkCellRange)
   Resume Next
End Function
'**************************************  
'ピボットテーブルでの集計結果を編集して集計表シートに集計表を作成  
'第一引数 rngCopyTo:作成するセルの位置(左上)(Range)  
'第二引数 pvtCopyFrom:集計表の元となるピボットテーブル(PivotTable)  
'第三引数 flg:シートを初期化したかどうかのフラグ、初期化されない場合は表頭を標記しない(Boolean)  
'***************************************  
Private Sub Set集計表シートへ転記(ByRef rngCopyTo As Range, _
                        ByRef pvtCopyFrom As PivotTable, _
                        ByVal flg As Boolean)
   '表頭の作成  
   If flg Then
       Set表頭 pvtCopyFrom.TableRange1.Rows(2), rngCopyTo
   End If
   '表側の作成  
   Set表側 pvtCopyFrom.RowRange, rngCopyTo.Offset(1)
   '表体の作成  
   Set表体 pvtCopyFrom.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)))
           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
 
'****************<プログラム終わり>***************************  
```
時間がありそうなのでコメントを入れてみました。  
 
他人が書いたコードは解読するのに苦労するとは思いますが、
参考になれば。
ここまで一から書くのに僕の力量で、ヘルプやオブジェクトブラウザで調べながら
だいたい4時間くらいかかりました。
ぜんぜん解らないところから始めるなら2週間~数か月かかるかも知れません。
解読してみてわからないところがあれば、
も少しピンポイントで質問してください。
どこから解説していいか解らないし、
全部解説してたら、どんだけ時間が掛かるかわからないし、
入門書1冊書けるくらいかかないといけないようになるので
参考サイト>>
[構造化プログラミングに挑戦しよう!](http://home.att.ne.jp/zeta/gen/excel/c03p06.htm)
[仕様要件からコードの組み立てを考える。](http://www.asahi-net.or.jp/~ef2o-inue/vba_k/sub04_160.html)
他にもいいサイトがある気がします。
探してみてください。
※文字数制限に引っかかったため、一部削除しました
3 追記

mattuwan

mattuwan score 2007

2020/01/17 22:59  投稿

う~ん。
なんで、エクセルに備わっている機能で出来ることを、
自作してるのですか?
「表」と言われている形の「クロス集計表」は、
「ピボットテーブル」という機能でデータのシートから、
作成可能です。
作業用のシートにそれを手動で設定しておけば、
マクロですることは、
1)データの参照範囲を再設定
2)ピボットテーブルの更新
3)結果を見せるシートにコピペして好みの形に再編集
ぐらいになると思いますがどうでしょうか?
---
> ① 4)にエラーが出ます。
> 先月まではエラーはありませんでした。
> 何が原因か分かりません。
>
>
> 実行時エラー1004
> アプリケーション定義またはオブジェクト定義のエラーです。
>
> .Add Type:=xlValidateList, _
>                AlertStyle:=xlValidAlertStop, _
>                Operator:=xlBetween, _
>                Formula1:="=名前リスト"
名前リストという名前の定義を消したのでは?
オブジェクト定義というのは、
今回の場合、指定されたセル範囲(=Rangeオブジェクトと呼ぶ)が存在しない場合によく出ます。
②について
上に書きましたが、自作するよりエクセル君が出来ることは、
エクセル君に任せた方が処理が速い場合が多いです。
意図が通じて無いようですが、
事前にピボットテーブルを設定したファイルを配布するのですから、
ユーザーがピボットテーブルを触ることはありません。
マクロで自動でやってもらうよう指示するだけです。
③について、
>1行空けて
with worksheets("?").usedrange
   .offset(.rows.count+2).cells(1)
end with
↑が貼付先のセルになると思います。
>列幅を揃える
エクセルにまかせていいなら、
worksheets("?").usedrange.entirecolumn.autofit
各列に既定の幅を設定するなら、
各列毎に設定してください。
コードはマクロの記録で探ることが可能だと思います。
④について
ピボットテーブルというのはまさにこういう表を作るための機能なので、
それを捨てて自分で一から、同じ機能を作るのはナンセンスかなと思いますが、
関数でも作成可能です。
表の縦横の項目名を参照して、合計するなら、
Sumifs関数が使えます。
[SUMIFS関数で複数の条件を指定して数値を合計す](https://dekiru.net/article/4365/)る
当然マクロで一から作ることも可能ですが、
処理速度はデータ数が多くなるほど処理が重くなると思います。
が、全然できないよりは出来た方がいいとおもいます。
が、テーマがたくさんあると、見る人が何に困っているかわかりずらいので、
別途質問してはいかがでしょうか?
---
> ②について教えて頂きたいのですが様式の表のように「場所+時間」を
> ピポッドで表示するにはどうのようにしたらよいのでしょうか?
「場所」は列ラベルでは?
![イメージ説明](81f8be99e85bd7d6398ec48699266a65.jpeg)
![イメージ説明](81f8be99e85bd7d6398ec48699266a65.jpeg)
---
> 表の様式は管理上変更できません。
>
> 表の様式をピポッドで作成する方法がありましたら教えて下さい。
う~ん。。。
ピボットテーブルで集計し、それをご自分の好きなように表示するよう加工することになります。
例えば、
自ブック(マクロを仕込むブック)に、
日報
集計表
作業用
の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 
```
                                                 
というようなデータがあるとして、
以下のようなコードで、
自分好みの表(そちらの希望に沿ってはいません。)を作ることが可能です。
あとの表示の順番や、列の具合、抽出したい月とかはそちらの希望するよう加工編集してください。
```ExcelVBA
Option Explicit
Sub Main()
   Dim rngWritingPosition As Range
   Set rngWritingPosition = Worksheets("集計表").Range("A1")
   Get表作成 "日付", "氏名,場所", rngWritingPosition
   With rngWritingPosition.CurrentRegion
       Set rngWritingPosition = .Cells(1).Offset(.Rows.Count)
   End With
   Get表作成 "場所", "氏名", rngWritingPosition, False
End Sub
Private Function Get表作成(ByVal strSideItem As String, _
                       ByVal strTopItem As String, _
                       ByRef rngTopLeft As Range, _
                       Optional flg As Boolean = True) As Range
   Dim pvtTable As PivotTable
   If flg Then
       rngTopLeft.Worksheet.UsedRange.Clear
   End If
   Set pvtTable = GetPvt集計(strSideItem, strTopItem)
   Set集計表シートへ転記 rngTopLeft, pvtTable, flg
   Set Get表作成 = rngTopLeft.CurrentRegion
End Function
Private Function GetPvt集計(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 wbk As Workbook
   Set wbk = ThisWorkbook
   Set rngSourceData = wbk.Worksheets("日報").Range("A1").CurrentRegion
   On Error GoTo ErrHandler
   Set pvtTable = wbk.Worksheets("作業用").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 GetPvt集計 = pvtTable
   Exit Function
ErrHandler:
   Set pvtCache = wbk.PivotCaches.Create( _
                  SourceType:=xlDatabase, _
                  SourceData:=rngSourceData)
   Set rngWorkCellRange = wbk.Worksheets("作業用").Range("A1")
   Set pvtTable = pvtCache.CreatePivotTable(TableDestination:=rngWorkCellRange)
   Resume Next
End Function
Private Sub Set集計表シートへ転記(ByRef rngCopyTo As Range, _
                        ByRef pvtCopyFrom As PivotTable, _
                        ByVal flg As Boolean)
   If flg Then
       Set表頭 pvtCopyFrom.TableRange1.Rows(2), rngCopyTo
   End If
   Set表側 pvtCopyFrom.RowRange, rngCopyTo.Offset(1)
   Set表体 pvtCopyFrom.DataBodyRange, rngCopyTo.Offset(1, 1), flg
   rngCopyTo.CurrentRegion.EntireColumn.AutoFit
End Sub
Private Sub Set表頭(ByRef rngFrom As Range, ByRef rngTo As Range)
   Dim v As Variant
   Dim ix As Long
   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
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
   vv = rngFrom.Value
   If flg Then
       With WorksheetFunction
           v = .Transpose(.Transpose(rngFrom.Rows(0)))
       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
```
他人が書いたコードは解読するのに苦労するとは思いますが、
参考になれば。
ここまで一から書くのに僕の力量で、ヘルプやオブジェクトブラウザで調べながら
だいたい4時間くらいかかりました。
ぜんぜん解らないところから始めるなら2週間~数か月かかるかも知れません。
解読してみてわからないところがあれば、
も少しピンポイントで質問してください。
どこから解説していいか解らないし、
全部解説してたら、どんだけ時間が掛かるかわからないし、
入門書1冊書けるくらいかかないといけないようになるので。
2 追記

mattuwan

mattuwan score 2007

2020/01/15 12:53  投稿

う~ん。
なんで、エクセルに備わっている機能で出来ることを、
自作してるのですか?
「表」と言われている形の「クロス集計表」は、
「ピボットテーブル」という機能でデータのシートから、
作成可能です。
作業用のシートにそれを手動で設定しておけば、
マクロですることは、
1)データの参照範囲を再設定
2)ピボットテーブルの更新
3)結果を見せるシートにコピペして好みの形に再編集
ぐらいになると思いますがどうでしょうか?
---
> ① 4)にエラーが出ます。
> 先月まではエラーはありませんでした。
> 何が原因か分かりません。
>
>
> 実行時エラー1004
> アプリケーション定義またはオブジェクト定義のエラーです。
>
> .Add Type:=xlValidateList, _
>                AlertStyle:=xlValidAlertStop, _
>                Operator:=xlBetween, _
>                Formula1:="=名前リスト"
名前リストという名前の定義を消したのでは?
オブジェクト定義というのは、
今回の場合、指定されたセル範囲(=Rangeオブジェクトと呼ぶ)が存在しない場合によく出ます。
②について
上に書きましたが、自作するよりエクセル君が出来ることは、
エクセル君に任せた方が処理が速い場合が多いです。
意図が通じて無いようですが、
事前にピボットテーブルを設定したファイルを配布するのですから、
ユーザーがピボットテーブルを触ることはありません。
マクロで自動でやってもらうよう指示するだけです。
③について、
>1行空けて
with worksheets("?").usedrange
   .offset(.rows.count+2).cells(1)
end with
↑が貼付先のセルになると思います。
>列幅を揃える
エクセルにまかせていいなら、
worksheets("?").usedrange.entirecolumn.autofit
各列に既定の幅を設定するなら、
各列毎に設定してください。
コードはマクロの記録で探ることが可能だと思います。
④について
ピボットテーブルというのはまさにこういう表を作るための機能なので、
それを捨てて自分で一から、同じ機能を作るのはナンセンスかなと思いますが、
関数でも作成可能です。
表の縦横の項目名を参照して、合計するなら、
Sumifs関数が使えます。
[SUMIFS関数で複数の条件を指定して数値を合計す](https://dekiru.net/article/4365/)る
当然マクロで一から作ることも可能ですが、
処理速度はデータ数が多くなるほど処理が重くなると思います。
が、全然できないよりは出来た方がいいとおもいます。
が、テーマがたくさんあると、見る人が何に困っているかわかりずらいので、
別途質問してはいかがでしょうか?
別途質問してはいかがでしょうか?
---
> ②について教えて頂きたいのですが様式の表のように「場所+時間」を
> ピポッドで表示するにはどうのようにしたらよいのでしょうか?
「場所」は列ラベルでは?
![イメージ説明](81f8be99e85bd7d6398ec48699266a65.jpeg)
1 追記

mattuwan

mattuwan score 2007

2020/01/10 16:33  投稿

う~ん。
なんで、エクセルに備わっている機能で出来ることを、
自作してるのですか?
「表」と言われている形の「クロス集計表」は、
「ピボットテーブル」という機能でデータのシートから、
作成可能です。
作業用のシートにそれを手動で設定しておけば、
マクロですることは、
1)データの参照範囲を再設定
2)ピボットテーブルの更新
3)結果を見せるシートにコピペして好みの形に再編集
ぐらいになると思いますがどうでしょうか?
ぐらいになると思いますがどうでしょうか?
---
> ① 4)にエラーが出ます。
> 先月まではエラーはありませんでした。
> 何が原因か分かりません。
>
>
> 実行時エラー1004
> アプリケーション定義またはオブジェクト定義のエラーです。
>
> .Add Type:=xlValidateList, _
>                AlertStyle:=xlValidAlertStop, _
>                Operator:=xlBetween, _
>                Formula1:="=名前リスト"
名前リストという名前の定義を消したのでは?
オブジェクト定義というのは、
今回の場合、指定されたセル範囲(=Rangeオブジェクトと呼ぶ)が存在しない場合によく出ます。
②について
上に書きましたが、自作するよりエクセル君が出来ることは、
エクセル君に任せた方が処理が速い場合が多いです。
意図が通じて無いようですが、
事前にピボットテーブルを設定したファイルを配布するのですから、
ユーザーがピボットテーブルを触ることはありません。
マクロで自動でやってもらうよう指示するだけです。
③について、
>1行空けて
with worksheets("?").usedrange
   .offset(.rows.count+2).cells(1)
end with
↑が貼付先のセルになると思います。
>列幅を揃える
エクセルにまかせていいなら、
worksheets("?").usedrange.entirecolumn.autofit
各列に既定の幅を設定するなら、
各列毎に設定してください。
コードはマクロの記録で探ることが可能だと思います。
④について
ピボットテーブルというのはまさにこういう表を作るための機能なので、
それを捨てて自分で一から、同じ機能を作るのはナンセンスかなと思いますが、
関数でも作成可能です。
表の縦横の項目名を参照して、合計するなら、
Sumifs関数が使えます。
[SUMIFS関数で複数の条件を指定して数値を合計す](https://dekiru.net/article/4365/)る
当然マクロで一から作ることも可能ですが、
処理速度はデータ数が多くなるほど処理が重くなると思います。
が、全然できないよりは出来た方がいいとおもいます。
が、テーマがたくさんあると、見る人が何に困っているかわかりずらいので、
別途質問してはいかがでしょうか?

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