[[20160212100623]]　『日付ごとに、複数件を横に転記していくマクロ』（まーた）　ページの最後に飛ぶ

『日付ごとに、複数件を横に転記していくマクロ』（まーた）

はじめまして。
なかなか方法が見つからず行き詰っております。

sheet1の表に、sheet2から日付（A列）ごと、且つ積載効率（C列）の大きい順に、左詰めで物量（B列）を転記するマクロを組みたいです。
問題点が、同日に複数の物量転記が発生した場合、右側にどんどん転記させるという方法です。
積載効率順にという条件は、sheet2を降順に並び替えてから、vlookupで日付ごとに転記させようと思っているのですが、どうしても複数転記が発生した際の、転記場所の指定方法がわかりません。

言葉足らずな部分や分かりにくい箇所があるかと思いますが、
お力をしていただけますでしょうか。どうぞよろしくお願いいたします。

【sheet1】　　　
　　A　　B　　C　　D　　E　F　G　H　I　
1 1/1 　金　
2 1/2 　土　　36
3 1/3 　日　　33　　37　39
4 1/4 　月　　27

    ・
　　・
　　・
31 1/31 　日
※発生がない場合は、空欄のままにしたいです。

【sheet2】

    　A  　　　B  　 　C   　　 
1  　日付　　物量　　積載効率
2　  1/2      36      68
3    1/3      37      70
4    1/3      33      74
5    1/3      39      61
6    1/4      27      89
     ・
　　 ・
全体件数は月によって変動。

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

 いろんなやりかたがありますが、素直に、ループさせて転記していく案です。

 （ここでアップしたコード、要件不足でしたので、削除します。）

（β） 2016/02/12(金) 13:35

 ↑　積載効率順をまったく無視してました。　その部分を追加して再掲します。

 17:38 Sheet1 と Sheet2 を取り違えていたので訂正して再掲します。

 Sub Test()
    Dim shT As Worksheet
    Dim c As Range
    Dim i As Long
    Dim stDate As Date
    Dim days As Long
    Dim sv As Variant

    Application.ScreenUpdating = False

    Set shT = Sheets("Sheet1")
    shT.Cells.ClearContents

    With Sheets("Sheet2").Range("A1").CurrentRegion
        sv = .Formula

        .Sort Key1:=.Range("A1"), Order1:=xlAscending, Key2:=.Range("C1"), Order2:=xlDescending, Header:=xlYes

        stDate = .Range("A2").Value
        stDate = DateSerial(Year(stDate), Month(stDate), 1)
        days = Day(DateAdd("m", 1, stDate) - 1)

        shT.Range("A1").Value = stDate
        shT.Range("A1").Resize(days).DataSeries Rowcol:=xlColumns, Type:=xlChronological, Date:=xlDay, Step:=1, Trend:=False
        shT.Range("B1").Resize(days).Formula = "=TEXT(A1,""aaa"")"

        For Each c In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
            i = Day(c.Value)
            shT.Cells(i, Columns.Count).End(xlToLeft).Offset(, 1).Value = c.Offset(, 1).Value
        Next

        .Value = sv

    End With

 End Sub

（β） 2016/02/12(金) 14:00

 データ量が膨大で、特に同じ日のデータが数多く登場するなら以下のほうが、ほんのちょびっと効率的かも。

 Sub Test2()
    Dim dic As Object
    Dim c As Object
    Dim d As Variant
    Dim x As Long
    Dim shT As Worksheet
    Dim stDate As Date
    Dim days As Long

    Application.ScreenUpdating = False

    Set shT = Sheets("Sheet1")
    Set dic = CreateObject("Scripting.Dictionary")
    shT.Cells.ClearContents

    With Sheets("Sheet2")

        stDate = .Range("A2").Value
        stDate = DateSerial(Year(stDate), Month(stDate), 1)
        days = Day(DateAdd("m", 1, stDate) - 1)

        shT.Range("A1").Value = stDate
        shT.Range("A1").Resize(days).DataSeries Rowcol:=xlColumns, Type:=xlChronological, Date:=xlDay, Step:=1, Trend:=False
        shT.Range("B1").Resize(days).Formula = "=TEXT(A1,""aaa"")"

        For Each c In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
            d = Day(c)
            If Not dic.exists(d) Then Set dic(d) = CreateObject("System.Collections.ArrayList")
            dic(d).Add CDbl(c.Offset(, 2).Value & "." & c.Offset(, 1).Value)
        Next

        For Each d In dic
            dic(d).Sort
            dic(d).Reverse
            For x = 0 To dic(d).Count - 1
                dic(d)(x) = Split(CStr(dic(d)(x)), ".")(1)
            Next
            shT.Cells(d, "C").Resize(, dic(d).Count).Value = dic(d).toarray
        Next
    End With

 End Sub

（β） 2016/02/12(金) 20:17

（β）さま
返信が遅くなりまして申し訳ありません。
ご回答ありがとうございました。
test2を使用させていただきます。
行き詰っていましたので、本当に助かりました。
ありがとうございました。

（まーた） 2016/02/15(月) 08:59

コメント返信：

[ 一覧(最新更新順) ]

[[20160212100623]] 『日付ごとに、複数件を横に転記していくマクロ』（まーた） ページの最後に飛ぶ

[[20160212100623]]　『日付ごとに、複数件を横に転記していくマクロ』（まーた）　ページの最後に飛ぶ