データを表かするにあたり

Question

前提・実現したいこと

シート名「結果」にA～K列までデータがあります。
これをシート名「仕様書」の順番に基づいて「表」に表として表示させたいです。

どこが原因か教えていただけますでしょうか。
よろしくお願いいたします。

発生している問題・エラーメッセージ

①シート名「表」に表が作成されずシート名「結果（2）」として作成されてしまう
②シート名「仕様書」の順番に基づいて並び替えられない。

該当のソースコード

①のコード

    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



    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 Worksheets(1)
    End With
    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
    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```

②のコード

Dim 仕様書, Rx As Long
 
    With Sheets("仕様書")
         仕様書 = .Range("B4:D" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
    End With
     
    With Sheets("表")
        For Rx = LBound(仕様書) To UBound(仕様書)
            .Columns(仕様書(Rx, 1) + 2).Copy Destination:=Sheets("表").Columns(仕様書(Rx, 3) + 2)
        Next
    End With
    
End Sub

該当のイメージ図

◆結果

◆表

◆仕様書

Comments

[meg_]

1行ずつ実行していけば原因が分かるかと思いますが、デバッグしてみましたか？

[ichigo15]

デバックはしてみましたが知識が低いため黄色のラインが移動しても
よく分かりません。
こつ等はありますでしょうか。

[meg_]

①については結果シートをコードのどこかで｢シートのコピー｣をしているはずです。デバッグしながら、ブックにシートが増えていないか観察してください。

[tatsu99]

結果、仕様書、表の３つのシートのレイアウトを画像で提示していただけませんでしょうか。

[Y.H.]

> シート名「表」
シート名「結果」をコピーしただけで、コードのどこにもシート名を「表」に変更していないですね。

[tatsu99]

シート名：仕様書の画像が提示されていません。（仕様書の代わりに結果の画像が提示されています）

[tatsu99]

表のシート名が「売上表」になっていますが、どちらが正しいのですか？

[ichigo15]

イメージ図の投稿が上手くいかず申し訳ございません。
追加しましたのでご確認ください。

デバックでシートが増えている箇所を探してみます。
それとシート名は「表」が正しいです。
こちらが原因かもしれませんので修正して試してみます。

ありがとうございます。

[ichigo15]

デバックでシートが増えている箇所を見つけましたので修正してみましたが
上手くいきませんでした。

Base = Intersect(.Range("D:K"), .Range(.Rows(2), .Rows(lr)))
.Copy Worksheets(1)

　　　　　　↓　こちらに修正

Base = Intersect(.Range("D:K"), .Range(.Rows(2), .Rows(lr)))
.Copy Worksheets("表")

Answer 1

とりあえず①の回答のみです。
.Copy Worksheets(1)
を行うと新規のワークシートにコピーされます。
表にコピーするには（コピーしたように見せるには）
１．表があるなら削除
２．結果を新規シートにコピー
３．新規シートを表にリネーム
する必要があります。以下のようにしてください。

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

Comments

[ichigo15]

If ExistsWorkSheet("表") = True Then
のExistsWorkSheetでエラーが出てしまいました

エラー：コンパイルエラー
　　　　subまたはFunctionが定義されてません

[tatsu99]

失礼しました。ExistsWorkSheetの関数がもれていましたので、追記しました。

[ichigo15]

ありがとうございます。
希望する結果となりました。
まだ理解できていない部分がありますが引続き勉強いたします。

Answer 2

表が正しく出力されていることが前提です。
仕様書のNoの順に氏名を並べ替えます。
No順に並べ替えるために一旦作業シート上でNo及び氏名をソートしています。
そのあとで作業シートを削除します。

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 '仕様書 C列最終行を求める
    maxrowW = ws.Cells(Rows.Count, "A").End(xlUp).Row '表 A列最終行を求める
    maxcolW = ws.Cells(1, Columns.Count).End(xlToLeft).Column   '表 1行目の最終列を求める
    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
    
    '仕様書のNo順に並べ直す
    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

Answer 3

＜結果＞シート

                                        
  日付        項目  場所  氏名  金額    
                                        
   2019/10/1  ああ  a     AA     10000  
                                        
   2019/10/1  いい  b     BB     15000  
                                        
  2019/11/15  うう  a     AA     20000  
                                        
  2019/11/15  うう  a     AA     25000  
                                        
  2019/12/20  ええ  e     CC     30000  
                                        
  2019/12/25  おお  f     BB     10000  
                                        
  2019/12/25  おお  g     BB     15000  
                                        
  2019/12/25  ああ  a     AA     50000  
                                        
  2019/12/29  いい  g     DD     20000  
                                        

＜仕様書＞シート

  No.   名前  
              
     1  BB    
              
     2  DD    
              
     3  CC    
              
     4  AA    

各シートがこんな感じで、
マクロを実行した結果が以下のように
なればいいのでしょうか？

＜表＞シート

                                                          
  合計 / 金額   列ラベル                                  
                                                          
  行ラベル      BB        DD      CC      AA      総計    
                                                          
  2019/10/1        15000                   10000   25000  
                                                          
  2019/11/15                               45000   45000  
                                                          
  2019/12/20                       30000           30000  
                                                          
  2019/12/25       25000                   50000   75000  
                                                          
  2019/12/29               20000                   20000  
                                                          
  総計             40000   20000   30000  105000  195000  
                                                          

マクロのコード

Option Explicit

Sub ListToCrossTable()
    Dim rngList As Range
    Dim rngTable As Range
    Dim rngName As Range
    Dim c As Range
    Dim i As Long
    Dim sixName As String
    Dim sixDate As String
    Dim sixAmount As String
    Dim pvtCache As PivotCache
    Dim pvtTable As PivotTable

    '準備（前提条件の定義）
    With ThisWorkbook
        Set rngList = .Worksheets("結果").Range("A1").CurrentRegion
        Set rngTable = .Worksheets("表").Range("A1")
        With .Worksheets("仕様書").Range("A1").CurrentRegion
            Set rngName = Intersect(.Cells, .Offset(1, 1))
        End With
        Set pvtCache = .PivotCaches.Create(xlDatabase, rngList)
    End With
    Set pvtTable = pvtCache.CreatePivotTable(rngTable)
    With rngList.Rows(1).Cells
        sixName = .Item(4).Value
        sixDate = .Item(1).Value
        sixAmount = .Item(5).Value
    End With

    'クロス集計表作成
    With pvtTable
        .PivotFields(sixName).Orientation = xlColumnField
        .PivotFields(sixDate).Orientation = xlRowField
        .AddDataField pvtTable.PivotFields(sixAmount), , xlSum
    End With
    
    '並べ替え
    For Each c In rngName
        i = i + 1
        pvtTable.PivotFields(sixName).PivotItems(c.Value).Position = i
    Next
End Sub

※各シートとも表の左上がA1セルとしてコードを書いています。
※エラー回避処理は一切考慮しておりません。

Comments

[ichigo15]

少し違っております。
＜表＞シートは金額のみではなく場所と金額をだします
それと、合計は日付ごとではなく人毎です

Answer 4

②についてですが、「表」シート同士でコピーしてもぐじゃぐじゃになるだけです。
一旦、表の内容をどこかにコピーし、それを表にコピーし直さないとだめです。

仕様書についてですが
Q1:仕様書の最大行数はC列の最後のデータがあるところで決めて良いですか。
マクロをみるとD列の最後のデータがあるところにしているように見える。

Q2：優先順位は、C列の上からの並び順で決めて良いですか。

添付図の左側図は、優先順位がAA,BB,CCの順ですが、これを優先順位CC,BB,AAに変える場合は、
添付図の中の図のように変えると考えてよいですか。（赤線の部分を変更）
それとも添付図の右側のように変えることも想定されているのですか。（青線の部分を変更）

優先順位を決めるとき、B列のNoの値も考慮し、その順序のしたいのか、
それとも、B列のNoの値には関係なく、C列の上からの並び順で決めて良いかという質問です。

Comments

[ichigo15]

仕様が分かりづらく申し訳ございません。

優先順位を決めるときはB列の番号で決めます。
従って添付図の中の図のように変えると考えてます（赤線の部分を変更）