エクセルのマクロについて

質問

お手数ですが誰か教えてください！

BのデーターをAに集計するマクロを作ったのですが
処理速度とっても遅いのです。

高速で処理する方法はありませんでしょうか？

私が作ったマクロ
Sub 集計()
Dim Z As Integer
Dim i As Integer
Dim X As Integer

For Z = 2 To 2000
For i = 2 To 2000
For X = 3 To 20

If Worksheets("A").cells(Z, 1) = Worksheets("B").cells(i, 1) And
　　　　　　Worksheets("A").cells(1, X) = Worksheets("B").cells(i, 14) Then

Worksheets("A").cells(Z, X) = Worksheets("B").cells(i, 16)
End If

Next X
Next i
Next Z

End Sub

　　　　　　どこかが間違っている気がしますがマクロ初心者のため
　　　　　　先に進めません。

　　　　　　どうかご教授よろしくお願い致します。

回答No.10

kmetu

ANo.8さんのコードですが、私がNo2で回答した質問のコードのFor Z = 2 To 2000のループをなくして、変数Zと書かれているところをiに置き換えた(一部書き換え損ねてますけど)のと結果同じじゃないのかなぁと思われますが…変数に代入してる部分だけ無駄なような…

データを見ると
Worksheets("A").cells(Z, 1) = Worksheets("B").cells(i, 1)
の比較は、AシートのA列のデータとBシートのA列のデータとを総当りという考え方ですね。ですから、同一行のデータを比較しただけではダメですので、2000回のループがネストしてなければいけないのだと思われます。

ただ、Zのループが2000まで必要かどうかは、Aシートの品目が2000品目あるのかどうか、iのループが2000まで必要かどうかは、それだけデータがあるかどうかにかかってきますけど。

ANo.6では必要回数をデータの入力されている最終行数分までとしています。

回答No.9

kmetu

またまた訂正です。
シートAの最終行までなのにシートBの最終行と間違ってました。

For MyRow = 2 To MyBottomRow
↓
For MyRow = 2 To Worksheets("A").Range("A" & Rows.Count).End(xlUp).Row

に変更してください。

回答No.8

米沢 栄蔵（@YON56）

ishinodaさんのマクロでは計算回数が、
1,999*1,999*18=71,928,018となります。
1回当たりどれくらいの時間が懸かっているのかは不明ですが
0.0001secとしても、7,193sec=119.9min懸かる計算です。

論理的には正しい構文でも、時間が懸り過ぎるのはダメです。

次の構文を提案します。
(1)論理対象データと書込データを収集します。
Sheets("A")から取得するデータ数はA2からA2000までの1999行1列の1999個
　 Sheets("B")から取得するデータ数はA2からA2000,N2からN2000,P2からP2000の1999行3列の5997個
データの仮置場を配列として定義します。
　 Dim AAA(),BBB()
ReDim AAA(2000)
ReDim BBB(2000,1)
　　　***仮置場の必要行数は1999行であるが、論理を単純化するため(計算回数を増やさないため)、2000行とした。
Sheets("A").Select
For Z=2 To 2000
AAA(Z)=Cells(Z,1).Value
Next Z
Sheets("B").Select
For i=2 To 2000
BBB(i,1)=Cells(i,1).Value
BBB(i,2)=Cells(i,14).Value
BBB(i,3)=Cells(i,16).Value
Next Z
(2)論理を実行し、必要部署に必要データを書込みます。
Sheets("A").Select
For Z=2 To 2000
If AAA(Z)=BBB(Z,1) Then
For X=3 To 20
If Cells(1,X)=BBB(Z,2) Then
Cells(Z,X)=BBB(Z,3)
End If
Next X
End If
Next Z

このマクロの計算回数は、
1,999*1+1,999*3+1,999*18=43,978となります。
43,978/71,928,018=0.0006
つまり計算時間が、約99.94%減少します。
これは大略の時間です。
その他の構文の実行もマクロ実行時間と関係します。

回答No.7

kmetu

変数の宣言に

Dim firstAddress As String

が抜けてましたので追加してください。

回答No.6

kmetu

マクロじゃなくて関数なら

C2に
=SUMPRODUCT((B!$A$2:$A$2000=A!$A2)*(B!$P$2:$P$2000=A!B$1)*(B!$N$2:$N$2000))
として必要なだけ右と下にコピーしたら結果が出ますよ。

マクロなら

Sub 集計()

Dim MyRow As Long, MyBottomRow As Long
Dim MyProductCode As Object
Dim MyDeliverydateColumn As Variant

MyBottomRow = Worksheets("B").Range("A" & Rows.Count).End(xlUp).Row
For MyRow = 2 To MyBottomRow
With Worksheets("B")
Set MyProductCode = .Range("A2:A" & MyBottomRow).Find(Worksheets("A").Range("A" & MyRow), LookIn:=xlValues)
If Not MyProductCode Is Nothing Then
firstAddress = MyProductCode.Address
Do
With Worksheets("A")
MyDeliverydateColumn = Application.Match(Worksheets("B").Range("P" & MyProductCode.Row), .Range(.Cells(1, 1), .Cells(1, .Cells(1, Columns.Count).End(xlToLeft).Column)), 0)
If IsNumeric(MyDeliverydateColumn) = True Then
.Cells(MyRow, MyDeliverydateColumn).Value = _
.Cells(MyRow, MyDeliverydateColumn).Value + Worksheets("B").Range("N" & MyProductCode.Row).Value
End If
End With
Set MyProductCode = .Range("A2:A" & MyBottomRow).FindNext(MyProductCode)
Loop While Not MyProductCode Is Nothing And MyProductCode.Address <> firstAddress
End If
End With
Next MyRow

End Sub

これでいけると思います。

回答No.5

kmetu

また訂正(笑)

Next Z

をEnd Withの後に付けてください。

お礼

早々のフォローありがとうございました。

End　withをつけて試してみます。

ちなみに私の元データーはこんな感じです。

Bシート
　　A列　　　　　　　　　 N列　　　　　　　 P列　　　　　　
品名コード　　　　　　　数量　　　　　 納入年月　　　　
　　No1　　　　　　　　　　3　　　　　　　2013年8月
　　No1　　　　　　　　　　2　　　　　　　2013年9月　　　　　
　　No1　　　　　　　　　　5　　　　　　　2013年10月
　　No2　　　　　　　　　　8　　　　　　　2013年8月
　　No2　　　　　　　　　　9　　　　　　　2013年10月
　　No3　　　　　　　　　　1　　　　　　　2013年9月
　　. . .
　　. . .

Aシート
A列 C列　　　　　　　　D列　　　　　　　F列　・・・・
　品名コード　 2013年8月　　　　2013年9月　　　　2013年10月・・・・　　
No1　　　　　　　
No2
No3
　　 　.
.

ここまではマクロで作成したのですが後は数量だけなのです。

ちなみにBシートの品名コードと納入年月は重複していますが

Aシートは重複していません。

元データはこんな感じです。

今さら送って申し訳ありません＞＜

回答No.4

kmetu

またふと思いつきましたが、もしかしたら

Dim Z As Integer
Dim X As Integer

For Z = 2 To 2000
With Worksheets("B").Range("A1:A2000")
Set c = .Find(Worksheets("A").Cells(Z, 1), LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
For X = 3 To 20
If Worksheets("A").Cells(1, X) = Worksheets("B").Cells(c.Row, 14) Then
Worksheets("A").Cells(Z, X) = Worksheets("B").Cells(c.Row, 16)
End If
Next X
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With

こんなのでいけるかも、また、よく考えてはいませんので動かなかったらすみません。

お礼

私の為に時間を費やしてくださって
本当にありがとうございます。

回答していただいたマクロですがマクロ初心者の私では
さっぱりわかりませんがいろいろ解読して勉強します。

本当に凄いです。

回答No.3

kmetu

訂正

Worksheets("A").Cells(Z, X) = Worksheets("B").Cells(i, 16)

↓

Worksheets("A").Cells(i, X) = Worksheets("B").Cells(i, 16)

回答No.2

kmetu

ふと思ったのですが

Worksheets("A").cells(Z, X) = Worksheets("B").cells(i, 16)

条件が合えば、同じ値を3列目から20列目まで18列にわたって代入することになると思われますが、そのあたり何か変更することはできないのでしょうか。

また、もしかしたらZのループは不要で

For i = 2 To 2000
If Worksheets("A").Cells(i, 1) = Worksheets("B").Cells(i, 1) Then
For X = 3 To 20
If Worksheets("A").Cells(1, X) = Worksheets("B").Cells(i, 14) Then
Worksheets("A").Cells(Z, X) = Worksheets("B").Cells(i, 16)
End If
Next X
End If
Next i

でいけるのではないかと思われたりします。あまり深くは考えていませんのでいけないかもしれません。

お礼

再度ご回答ありがとうございます。

確かにZループは不要かもしれません。

回答No.1

kmetu

実際のデータが分からないので、根本的に変更するということは私にはできませんので申し訳ありませんが

If Worksheets("A").cells(Z, 1) = Worksheets("B").cells(i, 1) And
　　　　　　Worksheets("A").cells(1, X) = Worksheets("B").cells(i, 14) Then

という条件ですから

Worksheets("A").cells(Z, 1) = Worksheets("B").cells(i, 1) でなければ
For X = 3 To 20を実行する必要が無いと思われますので

For Z = 2 To 2000
For i = 2 To 2000
If Worksheets("A").Cells(Z, 1) = Worksheets("B").Cells(i, 1) Then
For X = 3 To 20
If Worksheets("A").Cells(1, X) = Worksheets("B").Cells(i, 14) Then
Worksheets("A").Cells(Z, X) = Worksheets("B").Cells(i, 16)
End If
Next X
End If
Next i
Next Z

こうすると微妙に早くなるような気もしますが
Worksheets("A").Cells(Z, 1) = Worksheets("B").Cells(i, 1)
の条件がどれくらいヒットするのかに左右されますねぇ…

For i = 2 To 2000のループに入る前に、何かしらループに入らなくていい条件が見つかればかなり早くなると思います。

とりあえず参考までに

お礼

ご回答ありがとうございます。
ご回答頂いた内容ですと確かに
無駄が無くなり速くなる気が
します。
元のデーターは会社にあるので
明日試してみます。
勉強になりました。
ありがとうございます。