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