[[20080816124524]]　『上位抽出』（ひろ）　ページの最後に飛ぶ

『上位抽出』（ひろ）

 下記表から上位10項目を別シートに抽出し、更に前月・前年同月との比較を行いたいのですが
何を使えばいいか分からず、皆様の知恵を借りさせて下さい。

 品名　　品番　19.8個数　19.8金額　20.7個数　20.7金額　20.8個数　20.8金額
りんご　　Ｆ　　　20        100        25       125        21       105
みかん　　Ｄ　　　10　　　　100　　　　15       150        13       130
バナナ　　Ｒ　　　5　　　　　20　　　　10　　　　40　　　　 4　　　　16
　・
　・
　・

 上記のような表から、
品名　　品番　19.8金額　　品名　　品番　20.7金額　　品名　　品番　20.8金額
みかん　Ｄ　　　100　　　 みかん　 Ｄ　　　150　　　みかん　Ｄ　　　130
りんご　Ｆ　　　100　　　 りんご　 Ｆ　　　125　　　りんご　Ｆ　　　105
バナナ　Ｒ　　　 20　　　 バナナ　 Ｒ　　　 40　　　バナナ　Ｒ　　　 16
　・
　・
　・

 といったように、それぞれの月に対して品名・品番・金額を上位10項目で返して、更に
品名　　品番　20.8金額　20.7金額　19.8金額
みかん　Ｄ　　　130　　   150　　　　100
りんご　Ｆ　　　105　　　 125        100
バナナ　Ｒ　　　 16　　　  40         20
　・
　・
　・

 上記のように20.8を基準として、同じ品名が前月・前年同月いくらだったかを表示させたいのです。

 アドバイスお願い致します。

 （追記）
元データとなる表が期ごとに分かれているため、統合させずに式で参照出来れば幸いです。
19年8月は別シートにあり、20年度と比較すると品名の増減があります。
比較対象の無いものは0で返していただければと思います。

 レスが付かないようなんで、スレ上げ兼冷やかしマクロです。
 新しいブックで試してみませう。
 Alt+F11→挿入→標準モジュールに下のコードをコピペ。
 戻ってSheet1のA1からそれなりのデータを書き込みます。

 Alt+F8でhiroを実行してみてくらはい。
 Sheet2,Sheet3を開くと、どないでっか？
 　　　　　　（弥太郎）

 '--------------
 Sub hiro()
    Dim dic As Object, i As Long, u As Integer, f As Integer
    Dim tbl, x(1 To 10, 1 To 5), y(1 To 10, 1 To 9)
    Set dic = CreateObject("scripting.dictionary")
    Application.ScreenUpdating = False
    With Sheets("sheet1")
        tbl = .Range("a1").Resize(.Range("a" & Rows.Count).End(xlUp).Row, 8)
    End With
    Sheets.Add
    ActiveSheet.Name = "作業用"
    With Sheets("作業用")
        .Range("a1").Resize(UBound(tbl, 1), UBound(tbl, 2)) = tbl
        For u = 1 To 3
            .Range("a1").Resize(UBound(tbl, 1), UBound(tbl, 2)).Sort _
                key1:=.Cells(1, 2 + u * 2), Order1:=xlDescending
            tbl = .Range("a1").Resize(UBound(tbl, 1), UBound(tbl, 2))
                f = IIf(u = 1, 1, IIf(u = 2, 4, 7))
                For i = 2 To 11
                    y(i - 1, f) = tbl(i, 1)
                    y(i - 1, f + 1) = tbl(i, 2)
                    y(i - 1, f + 2) = tbl(i, 2 + u * 2)
                    If u = 3 Then
                        x(i - 1, 1) = tbl(i, 1)
                        x(i - 1, 2) = tbl(i, 2)
                        x(i - 1, 3) = tbl(i, 8)
                        dic(tbl(i, 1)) = i - 1
                    End If
                Next i
        Next u
        With Sheets("sheet2")
            .Cells.ClearContents
            .Cells(1, 1).Resize(, 9) = Array("品名", "品番", tbl(1, 4), "品名", "品番", _
                    tbl(1, 6), "品名", "品番", tbl(1, 8))
            .Cells(2, 1).Resize(UBound(y, 1), UBound(y, 2)) = y
        End With
        For u = 2 To 3
            For i = 2 To UBound(tbl, 1)
                If dic.exists(tbl(i, 1)) Then
                    x(dic(tbl(i, 1)), u + 2) = tbl(i, 10 - u * 2)
                End If
            Next i
        Next u
    End With
    With Sheets("sheet3")
        .Cells.ClearContents
        .Range("a1").Resize(, 5) = Array("品名", "品番", tbl(1, 8), tbl(1, 6), tbl(1, 4))
        .Range("a2").Resize(UBound(x, 1), UBound(x, 2)) = x
    End With
    Application.DisplayAlerts = False
    Sheets("作業用").Delete
    Application.ScreenUpdating = True
 End Sub

コメント返信：

[ 一覧(最新更新順) ]

[[20080816124524]] 『上位抽出』（ひろ） ページの最後に飛ぶ

[[20080816124524]]　『上位抽出』（ひろ）　ページの最後に飛ぶ