[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『転記時間を短縮したい』(もあ)
いつもお世話になっております
同ブック内別シートにマクロにて転記するにあたり、時間がかかりすぎな為、どうにかして時間短縮できないでしょうか 配列は最近手を出し始めたばかりで、使いこなせませんので見苦しく、申し訳ございません
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.