[[20200602141636]]　『列ごと3番目の列の下に移動を繰り返したい』（アークン）　ページの最後に飛ぶ

『列ごと3番目の列の下に移動を繰り返したい』（アークン）

SHEET Aのような表が合って、右横5列見出しはそれぞれ日付です。
これをSHEET Bのような日付順、部門(DEPT.)順、ビル番号(BUIL.)順に
並び替えたいのですが、このようなファイルが大量にあるのと、
それぞれのファイルでDEPT. の行数がまちまち(あるファイルでは10が3行、あるファイルは7行あったりします)なので、記録式マクロでは対応できないと思います。

イメージとしては、この例ですと8/2の列を、8/1列の下に順次移動して、ついでにその日付を一番左の列に挿入して行く。次にその下に8/3の列のデータを移動,次に8/4の列をその下に..という繰り返しです。

何か良い方法はないでしょうか。

[SHEET A]
　　　　　　　　
DEPT. BUIL. 8/1 8/2 8/3 8/4 8/5

10 AAA 110 210 310 410 510
10 BBB 200 300 400 500 600
10 CCC 10 124,138 200 300 400
20 AAA 10 124,138 200 300 400
20 BBB 1 2 3 4 5
20 CCC 5 6 7 8 9
30 AAA 10 124,138 200 300 400
30 BBB 1 2 3 4 5
30 CCC 0 0 0 0 0
40 AAA 5 6 7 8 9
40 BBB 200 300 400 500 600
40 CCC 10 124,138 200 300 400

[SHEET B]

DATE DEPT. BUIL. 実績
8/1 10 AAA 110
8/1 10 BBB 200
8/1 10 CCC 10
8/1 20 AAA 10
8/1 20 BBB 1
8/1 20 CCC 5
8/1 30 AAA 10
8/1 30 BBB 1
8/1 30 CCC 327,190
8/1 40 AAA 5
8/1 40 BBB 200
8/1 40 CCC 10
8/2 10 AAA 210
8/2 10 BBB 300
8/2 10 CCC 0
8/2 20 AAA 124,138
8/2 20 BBB 2
8/2 20 CCC 6
8/2 30 AAA 124,138
8/2 30 BBB 2
8/2 30 CCC 0
8/2 40 AAA 6
8/2 40 BBB 300
8/2 40 CCC 124,138
8/3 10 AAA 310
8/3 10 BBB 400
8/3 10 CCC 200
8/3 20 AAA 200
8/3 20 BBB 3
8/3 20 CCC 7
8/3 30 AAA 200
8/3 30 BBB 3
8/3 30 CCC 0
8/3 40 AAA 7
8/3 40 BBB 400
8/3 40 CCC 200
8/4 10 AAA 410
8/4 10 BBB 500
8/4 10 CCC 300
8/4 20 AAA 300
8/4 20 BBB 4
8/4 20 CCC 8
8/4 30 AAA 300
8/4 30 BBB 4
8/4 30 CCC 581,037
8/4 40 AAA 8
8/4 40 BBB 500
8/4 40 CCC 300
8/5 10 AAA 510
8/5 10 BBB 600
8/5 10 CCC 400
8/5 20 AAA 400
8/5 20 BBB 5
8/5 20 CCC 9
8/5 30 AAA 400
8/5 30 BBB 5
8/5 30 CCC 0
8/5 40 AAA 9
8/5 40 BBB 600
8/5 40 CCC 400

＜使用 Excel：Excel2016、使用 OS：Windows7 ＞

マクロが苦手なら、このあたりを試してみてはどうでしょうか

（マナ） 2020/06/02(火) 22:43

リンク貼り忘れていました
https://hamachan.info/excel2019-cross/

（マナ） 2020/06/03(水) 08:00

 こんにちは　＾＾ エクセル。。。便利ですね(*^^*)
マクロでちゃちゃっとすますなら。。。いろいろと方法は有ると思いますが
１．配列に取り込む
２．それを必要な箇所から横、縦、とループ処理で、御入用の物を読み込む
３．別途用意した、配列にぽいぽい、と入れる
４．最後に一括で、所定の箇所へ書き出す。
とかでも出来なくは無いかと。。。←　多分　＾＾；　m(_ _)m
（隠居じーさん） 2020/06/03(水) 09:40

ピボットを試してみましたが、うまく行きません。
例示いただいたサイトはデータの種類数が違うのと、EXCELバージョンも2019の場合の画面展開のようで、私の理解を超えておりました。(こちらEXCEL2013です..)
（アークン） 2020/06/03(水) 17:37

 >(こちらEXCEL2013です..)
 Excel2016じゃないの?
（mar） 2020/06/03(水) 17:58

 Sub test()
    Dim wk1 As Worksheet
    Dim wk2 As Worksheet
    Dim i As Long
    Dim j As Long
    Dim iMax As Long
    Dim jMax As Long
    Dim iR As Long

    Set wk1 = Sheets("SheetA")
    Set wk2 = Sheets("SheetB")

    iMax = wk1.Cells(1, wk1.Columns.Count).End(xlToLeft).Column
    jMax = wk1.Cells(wk1.Rows.Count, "A").End(xlUp).Row
    iR = 1

    wk2.Range("A1:D1") = Array("DATE", "DEPT.", "BUIL.", "実績")
    For i = 3 To iMax
        For j = 2 To jMax
            iR = iR + 1
            wk2.Cells(iR, "A").Value = wk1.Cells(1, i).Value
            wk2.Cells(iR, "B").Value = wk1.Cells(j, "A").Value
            wk2.Cells(iR, "C").Value = wk1.Cells(j, "B").Value
            wk2.Cells(iR, "D").Value = wk1.Cells(j, i).Value
        Next j
    Next i
 End Sub
（???） 2020/06/03(水) 18:06

 こんばんは　＾＾
既に適切なご案内があるようですが。作ってみましたので。。。
ワークシート　Sheet1　が元情報で
ワークシート　Sheet2　を初期化後、書き出しています。
Option Explicit
Sub OneInstanceMain()
    Const zProgramID  As String = "IJ00024.xlsm"
    Dim zTb           As Workbook
    Dim i             As Long
    Dim j             As Long
    Dim zBase()       As Variant
    Dim zd            As Object
    Dim t             As Date
    t = Timer
    Set zTb = Workbooks(zProgramID)
    Set zd = CreateObject("System.Collections.ArrayList")
    With zTb.Worksheets("Sheet1")
        zBase = .Cells(1).CurrentRegion.Value
    End With
    For i = 3 To UBound(zBase, 2)
        For j = 2 To UBound(zBase, 1)
            zd.Add Array(zBase(1, i), zBase(j, 1), zBase(j, 2), zBase(j, i))
        Next
    Next
    With zTb.Worksheets("Sheet2")
        .UsedRange.Clear
        .Cells(1).Resize(, 4) = Array("Date", "DEPT", "BUIL", "実績")
        .Cells(2, 1).Resize(zd.Count, 4) = Application.Transpose(Application.Transpose(zd.ToArray))
        .UsedRange.Offset(1).Resize(.UsedRange.Rows.Count - 1, _
        .UsedRange.Columns.Count).Columns(4).NumberFormatLocal = "#,0"
    End With
    zd.Clear
    Erase zBase
    Set zd = Nothing
    Set zTb = Nothing
    MsgBox "終了　" & Format(Timer - t, "0.0") & "　秒"
End Sub
（隠居じーさん） 2020/06/03(水) 19:50

＞ピボットを試してみましたが、うまく行きません。

ごめんなさい。確かにそうでした。
作業列作って、DEPT.とBUIL.フィールドを結合せて
最後に、区切り位置で分割するとできました。

下記のマクロをステップ実行してみてください。
手作業なら、こんな手順になる、という例です。

すでに、マクロでの回答がありますし
手作業だと、ステップ数も多いので、
マクロがよいのかもしれませんが、参考まで。

 Sub test()
    Dim ws As Worksheet
    Dim tbl As Range
    Dim pvc As PivotCache
    Dim pvt As PivotTable
    Dim pvf As PivotField
    Dim r As Range

    Set ws = ActiveSheet
    ws.Columns(3).Insert
    Set tbl = Cells(3).CurrentRegion
    tbl.Columns(3).Formula = "=a1&""_""&b1"
    Set tbl = tbl.Resize(, tbl.Columns.Count - 2).Offset(, 2)

    Set pvc = ws.Parent.PivotCaches.Create(xlConsolidation, tbl.Address(, , xlR1C1, True))
    Set pvt = pvc.CreatePivotTable(tbl(1).Offset(, tbl.Columns.Count + 2))

    pvt.RowAxisLayout xlTabularRow
    pvt.ColumnGrand = False
    pvt.RowGrand = False
    For Each pvf In pvt.PivotFields
        pvf.Subtotals(1) = False
    Next
    pvt.RepeatAllLabels xlRepeatLabels
    pvt.AddFields RowFields:=Array("列", "行")

    Set r = pvt.TableRange1

    r.Copy
    r.PasteSpecial xlPasteValues
    r.Columns(1).NumberFormatLocal = "m/d"
    r.Columns(3).Insert
    r.Columns(2).TextToColumns DataType:=xlDelimited, Other:=True, Other:="_"
    r.Rows(1).Value = Array("DATE", "DEPT.", "BUIL.", "実績")

    tbl.Columns(1).Delete xlToLeft

 End Sub

（マナ） 2020/06/03(水) 20:49

???さん、隠居じーさん、マナさん　ありがとうございます！早速やってみます。
（アークン） 2020/06/04(木) 08:51

結局、マナさんの"作業列作って、DEPT.とBUIL.フィールドを結合せて"というコメントに助けられ、ピボットでできました。あとはマクロとのパフォーマンスの勝負になりますが、ひとまずできましたのでお礼申し上げます。
（アークン） 2020/06/04(木) 11:50

コメント返信：

[ 一覧(最新更新順) ]

[[20200602141636]] 『列ごと3番目の列の下に移動を繰り返したい』（アークン） ページの最後に飛ぶ

[[20200602141636]]　『列ごと3番目の列の下に移動を繰り返したい』（アークン）　ページの最後に飛ぶ