excel2003 で処理の早い記述があれば

質問

XCEL2003 VBAで質問です。よろしくお願いします。

まず、リンク先の写真を参照お願いします。
https://www.dropbox.com/s/01saveqkt1u93zj/%E3%82%AD%E3%83%A3%E3%83%97%E3%83%81%E3%83%A3.JPG?dl=0

Ａ列－連続番号の数字
Ｂ列－名称があり、あらかじめ昇順に並んでいます。
同じ名前が複数行続く場合と、そうでない場合があります。
Ｃ列～Ｈ列－同じ名称(ひとつの名称）の中でそれぞれ計１個か、０個データが入っています。

これを別のシートで、写真の下表の様に、一つの名称を一行にまとめたいです。
この時 数値の入っているデータは、一行に集合して表示されます。

私のVBAの記述だと、オートフィルタで一件ずつ名称を抽出して、コピーの空白セルを無視して貼り付けるというやり方で、一行にまとめていますが、データが一万件ぐらいあり、いまいち処理が遅くて困っています。

どういう記述だと処理が早いか教えてもらえないでしょうか？

回答No.2

MarcoRossiItaly · ベストアンサー

2003 であっても Excel には「統合」という機能があり、お望みの処理がパッとできます。オートフィルタではありません。これを手動またはマクロを使って動かしてください。まずは参考 URL などを読んで、統合について学んでください。

マクロ記録をしてもらえば分かりますが、Range.Consolidate メソッドが統合に相当します。VBA のヘルプも参照してください。

添付図では、表示されているダイアログで OK することにより、B19 セルの位置に統合されたデータが貼り付けられました。A 列は、わざと除外して統合しています。A 列へのデータの記入については、統合の後で、「WorksheetFunction.VLookup メソッドにより検索した NO」を空白セルの Value プロパティに、あるいは「VLOOKUP 関数を含む数式」を同じ範囲の Formula プロパティに代入すればいいだけですね。

参考URL：

http://www.eurus.dti.ne.jp/~yoneyama/Excel/tougou.html

お礼

回答ありがとうございました。
EXCELにそんな便利な機能があるなんて、知りませんでした。
是非、統合を使い込んで、活用させていただきたいと思います。
ありがとうございました。

回答No.3

tom04

こんばんは！
どれだけ短縮できるか判りませんが、一例です。

Sheet1のデータをSheet2に表示するようにしてみました。
尚、Sheet3を作業用のSheetとして使用していますので、Sheet3は使用していない状態にしておいてください。
標準モジュールです。

Sub Sample1()
Dim i As Long, j As Long, k As Long
Dim lastRow As Long, endRow As Long, myMax As Long, c As Range
Dim wS2 As Worksheet, wS3 As Worksheet
Set wS2 = Worksheets("Sheet2")
Set wS3 = Worksheets("Sheet3")
Application.ScreenUpdating = False
wS2.Cells.Clear
With Worksheets("Sheet1")
.Rows(1).Copy wS2.Range("A1")
lastRow = .Cells(Rows.Count, "B").End(xlUp).Row
.Range("B:B").AdvancedFilter Action:=xlFilterCopy, copytorange:=wS3.Range("I1"), unique:=True
For i = 2 To wS3.Cells(Rows.Count, "I").End(xlUp).Row
On Error Resume Next '←念のため
.Range("A1").AutoFilter field:=2, Criteria1:=wS3.Cells(i, "I")
endRow = .Cells(Rows.Count, "B").End(xlUp).Row
If endRow > 1 Then
Range(.Cells(2, "C"), .Cells(lastRow, "H")).SpecialCells(xlCellTypeVisible).Copy wS3.Range("C2")
myMax = 0
For j = 3 To 8
myMax = WorksheetFunction.Max(myMax, WorksheetFunction.CountA(wS3.Columns(j)))
Next j
If myMax > 0 Then
Range(wS3.Cells(2, "C"), wS3.Cells(endRow, "H")).SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
Range(wS3.Cells(2, "B"), wS3.Cells(myMax + 1, "B")) = wS3.Cells(i, "I")
Set c = .Range("B:B").Find(wS3.Cells(i, "I"), LookIn:=xlValues, lookat:=xlWhole)
wS3.Cells(2, "A") = .Cells(c.Row, "A")
If myMax > 1 Then
For k = 3 To myMax
wS3.Cells(k, "B") = wS3.Cells(k - 1, "B") + 1
Next k
End If
Range(wS3.Cells(2, "A"), wS3.Cells(myMax + 1, "H")).Cut wS2.Cells(Rows.Count, "A").End(xlUp).Offset(1)
End If
End If
Next i
wS3.Range("I:I").Clear
.AutoFilterMode = False
End With
Application.ScreenUpdating = True
wS2.Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous
wS2.Activate
End Sub

※　じっくり考えればもっと簡単になるかもしれませんが
とりあえずはこの程度で・・・m(_ _)m

お礼

ありがとうございました。
まだ理解できていませんが、
後日改めて勉強させていただきます。

回答No.1

watabe007

参考に
Sub Test()
　　Dim v1 As Variant, v2 As Variant
　　Dim 名称 As String, i As Long, j As Long, ii As Long

　　v1 = Range("A3", Cells(Rows.Count, "A").End(xlUp)).Resize(, 8)
　　ReDim v2(1 To UBound(v1), 1 To 8)
　　For i = 1 To UBound(v1)
　　　　If v1(i, 2) <> 名称 Then
　　　　　　名称 = v1(i, 2)
　　　　　　ii = ii + 1
　　　　　　v2(ii, 1) = v1(i, 1)
　　　　End If
　　　　For j = 2 To 8
　　　　　　If v1(i, j) <> "" Then v2(ii, j) = v1(i, j)
　　　　Next j
　　Next i
　　Worksheets("別シート").Range("A3").Resize(UBound(v1), 8).Value = v2
End Sub

お礼

回答ありがとうございました。
すごく、上手に短文に集約されていて、
読みやすかったです。
理解するのに、時間がかかり、お礼が遅れて
すみませんでした。