[[20141118111716]] 『転記時間を短縮したい』(もあ) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『転記時間を短縮したい』(もあ)

 いつもお世話になっております

 同ブック内別シートにマクロにて転記するにあたり、時間がかかりすぎな為、どうにかして時間短縮できないでしょうか
 配列は最近手を出し始めたばかりで、使いこなせませんので見苦しく、申し訳ございません

 Sheet1のA列に名前(ランダム順)、B列〜M列、O列〜T列まで数値(時々"-")が入っております
 N列は空白で、2行目まで見出し、3行目からだいたい360行くらいを想定しております
 それをSheet2の同じ名前(重複なし、固定)のところに転記したいのです
 Sheet2の見出しは9行目、C列に名前、H〜J列*4行に数値、の4行で1単位です
 C列は4行ごとに同じ名前が入力されています(フィルタ用)

 Sheet2のC10の名前のデータをSheet1から探し、その該当行(121行とする)のB列データを
 Sheet2のH10に転記(Sheet2!H10=Sheet1!B121)したいです
 以下、Sheet2!I10=Sheet1!C121、Sheet2!J10=Sheet1!D121
 Sheet2!H11=Sheet1!E121、Sheet2!I11=Sheet1!F121、Sheet2!J11=Sheet1!G121
 Sheet2!H12=Sheet1!O121、Sheet2!I12=Sheet1!P121、Sheet2!J12=Sheet1!Q121
 Sheet2!H13=Sheet1!R121、Sheet2!I13=Sheet1!S121、Sheet2!J13=Sheet1!T121

 【Sheet1】
 	A	B	〜	M	N	O	〜	T
 1
 2
 3	名前A	数値	〜	数値		数値	〜	数値
 〜略
 121	名前B	数値1	〜	数値12		数値13	〜	数値18
 122	名前C	数値	〜	数値		数値	〜	数値
 〜略								
 360	名前D	数値	〜	数値		数値	〜	数値

 【Sheet2】
 	〜	C	〜	H	I	J
 10	〜	名前B	〜	数値1	数値2	数値3	┐
 11	〜	名前B	〜	数値4	数値5	数値6	│4行1単位 
 12	〜	名前B	〜	数値13	数値14	数値15	│
 13	〜	名前B	〜	数値16	数値17	数値18	┘
 14	〜	名前F	〜	数値	数値	数値
 15	〜	名前F	〜	数値	数値	数値
 16	〜	名前F	〜	数値	数値	数値
 17	〜	名前F	〜	数値	数値	数値
 18	〜	名前W	〜	数値	数値	数値
 〜略						
 1500

 Sub 日報()
     Dim 元Dic As Object, myItem
     Set 元Dic = CreateObject("Scripting.Dictionary")
     Dim i As Long, j As Long, k As Long

     With ThisWorkbook
         With .Sheets("Sheet1")
             For i = 3 To .Cells(Rows.Count, 1).End(xlUp).Row
                 元Dic.Add .Cells(i, 1).Value, .Cells(i, 2).Value & "_" & .Cells(i, 3).Value & "_" & .Cells(i, 4).Value & "_" _
                                                     & .Cells(i, 5).Value & "_" & .Cells(i, 6).Value & "_" & .Cells(i, 7).Value & "_" _
                                                     & .Cells(i, 15).Value & "_" & .Cells(i, 16).Value & "_" & .Cells(i, 17).Value & "_" _
                                                     & .Cells(i, 18).Value & "_" & .Cells(i, 19).Value & "_" & .Cells(i, 20).Value
             Next i
         End With

 '        .Sheets("Sheet2").Copy Before:=Sheets(1)
 '        .Sheets("Sheet2").Name = "日報"

         With .Sheets("Sheet2")
             On Error Resume Next
             k = 0
             j = 8

 '	どう頑張っても行と列と配列番号の関係性が見つけられない
             For i = 10 To .Cells(Rows.Count, 2).End(xlUp).Row Step 4
                 myItem = Split(元Dic.Item(.Cells(i, 3).Value), "_")

                 .Cells(i, j).Value = myItem(0)
                 .Cells(i, j + 1).Value = myItem(1)
                 .Cells(i, j + 2).Value = myItem(2)

                 .Cells(i + 1, j).Value = myItem(3)
                 .Cells(i + 1, j + 1).Value = myItem(4)
                 .Cells(i + 1, j + 2).Value = myItem(5)

                 .Cells(i + 2, j).Value = myItem(6)
                 .Cells(i + 2, j + 1).Value = myItem(7)
                 .Cells(i + 2, j + 2).Value = myItem(8)

                 .Cells(i + 3, j).Value = myItem(9)
                 .Cells(i + 3, j + 1).Value = myItem(10)
                 .Cells(i + 3, j + 2).Value = myItem(11)

             Next i
             On Error GoTo 0
         End With
     End With   
 End Sub

 長々と申し訳ございませんが、なにとぞよろしくお願いいたします

< 使用 Excel:Excel2010、使用 OS:Windows7 >


 全部みたわけじゃないですが、セル一つずつに書き込みしているため遅くなっていると思います。
 こういうところ
 >.Cells(i, j).Value = myItem(0)
 >.Cells(i, j + 1).Value = myItem(1)
 >.Cells(i, j + 2).Value = myItem(2)

 二次配列にデータを入れて、いっぺんに書き出すなど工夫すればよいように感じます。
 .Cells(i, j).Resize(, 2).Value = myItem
 こんな感じに

 これで分からなければもう少し具体的に説明します。
(稲葉) 2014/11/18(火) 13:38

 稲葉さん
 長々と書いてしまって、本当に読みにくいと思います。すみません

 >二次配列にデータを入れて、いっぺんに書き出すなど工夫すればよいように感じます。
 >.Cells(i, j).Resize(, 2).Value = myItem
 >こんな感じに

 いまmyItem(11)ですけど、それをmyItem(4,3)にして、
 .Resize(,2)のなかに並べる。それを4行分ってことですか?
 dic内のItemを"_"でSplitして、2次元配列に入れる方法がわかりません

 申し訳ございませんが、教えていただいてもよろしいでしょうか?
(もあ) 2014/11/18(火) 16:34

 Resizeは2じゃなくて3でしたねぇ・・・すみません。

 一例ですけど、私ならこういう書き方します。
    Sub もあ()
        Dim dic As Object:    Set dic = CreateObject("Scripting.Dictionary")
        Dim WS1 As Worksheet: Set WS1 = Sheets("Sheet1")
        Dim WS2 As Worksheet: Set WS2 = Sheets("Sheet2")
        Dim a, w
        Dim b As String
        Dim n As Long, m As Long
        Dim r As Long, c As Long

        '元データをaに格納し、For Eachで必要な列番号をwに転記し、dicに取り込む
        a = WS1.Range("T3", WS1.Range("A" & Rows.Count).End(xlUp)).Value
        For n = 1 To UBound(a, 1)
            b = a(n, 1)
            If Not dic.exists(b) Then
                dic.Add b, ""
                ReDim w(1 To 4, 1 To 3)
                r = 1: c = 1
                For Each m In Array(2, 3, 4, 5, 6, 7, 15, 16, 17, 18, 19, 20)
                    w(r, c) = a(n, m)
                    r = IIf(c = 3, r + 1, r)
                    c = IIf(c < 3, c + 1, 1)
                Next m
                dic(b) = w
            End If
        Next n

        '転記先のデータをaに上書きし、
        a = WS2.Range("C10", WS2.Range("C" & Rows.Count).End(xlUp)).Resize(, 3).Value
        For n = 1 To UBound(a, 1) Step 4
            b = a(n, 1)
            If dic.exists(b) Then
                For m = 1 To 3
                    a(n + 0, m) = dic(b)(1, m)
                    a(n + 1, m) = dic(b)(2, m)
                    a(n + 2, m) = dic(b)(3, m)
                    a(n + 3, m) = dic(b)(4, m)
                Next m
            End If
        Next n

        '転記先シートに出力する
        WS2.Range("H10").Resize(UBound(a, 1), 3).Value = a
    End Sub

(稲葉) 2014/11/18(火) 18:28


 >Range("T3", WS1.Range("A" & Rows.Count).End(xlUp)).Value
 この書き方に感動しました

 > If dic.exists(b) Then
 数学の公式のように覚えて、重複しないように使うとしか考えていませんでした
 そうか、書出しは重複したときの作業ですね…

 >ReDim w(1 To 4, 1 To 3)
 > r = IIf(c = 3, r + 1, r)
 > c = IIf(c < 3, c + 1, 1)
 こう書くんですね……
 一昨日は、2次元配列の作り方はわかったものの、数字の運びをどう表せばいいのかわからず、躓いておりました

 配列は本当に理解していないので昨日はコードは追えども、もやっとしたままだったので、
 他の件に応用してみて、やっとふんわりわかりました
 もう少しすぐに理解できるようにつとめます

 今回の教えていただいたコードで、他のいろいろな件(特にアクセスからの書き出し)も一瞬で処理が終わりそうです

 お礼が遅くなり、申し訳ございませんでした
 感謝の気持ちでいっぱいです
 本当にありがとうございました 
(もあ) 2014/11/20(木) 09:44

コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.