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

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

ただいまの
回答率

89.21%

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

解決済

回答 4

投稿 編集

  • 評価
  • クリップ 1
  • VIEW 379

ichigo15

score 13

前提・実現したいこと

シート名「結果」に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  

該当のイメージ図

◆結果

イメージ説明

◆表

イメージ説明

◆仕様書

イメージ説明

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

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

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

    クリップを取り消します

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

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

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

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

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

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

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

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

    質問の評価を下げる

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

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

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

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

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

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

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

    詳細な説明はこちら

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

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

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

質問への追記・修正、ベストアンサー選択の依頼

  • tatsu99

    2019/12/19 20:34

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

    キャンセル

  • ichigo15

    2019/12/20 09:09

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

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

    ありがとうございます。

    キャンセル

  • ichigo15

    2019/12/20 15:29

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

    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("表")

    キャンセル

回答 4

checkベストアンサー

+1

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

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

投稿

編集

  • 回答の評価を上げる

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

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

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

  • 回答の評価を下げる

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

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

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

  • 2019/12/23 11:43

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

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

    キャンセル

  • 2019/12/23 11:50

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

    キャンセル

  • 2019/12/24 13:55

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

    キャンセル

0

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

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

Q2:優先順位は、C列の上からの並び順で決めて良いですか。
添付図
添付図の左側図は、優先順位がAA,BB,CCの順ですが、これを優先順位CC,BB,AAに変える場合は、
添付図の中の図のように変えると考えてよいですか。(赤線の部分を変更)
それとも添付図の右側のように変えることも想定されているのですか。(青線の部分を変更)

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

投稿

  • 回答の評価を上げる

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

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

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

  • 回答の評価を下げる

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

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

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

  • 2019/12/23 11:38

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

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

    キャンセル

0

<結果>シート

  日付        項目  場所  氏名  金額    

   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セルとしてコードを書いています。
※エラー回避処理は一切考慮しておりません。

投稿

  • 回答の評価を上げる

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

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

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

  • 回答の評価を下げる

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

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

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

  • 2019/12/23 11:26

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

    キャンセル

0

表が正しく出力されていることが前提です。
仕様書の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

投稿

  • 回答の評価を上げる

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

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

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

  • 回答の評価を下げる

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

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

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

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

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