エクセル VBA データ並び替えと行削除

質問

エクセル2003にて　VBA初心者です。

以下のようなデータがあります。
　列A　　　　列B　　　　　列C
　識別　　　部品番号　　ユニット
　　　　　　　 A10000　　　*100
　　　　　　　 A10001　　　*101
　　　　　　　 A10002　　　*102
　＊　　　　　A10002　　　*103
　　　　　　　 A10003　　　*104
　＊　　　　　A10003　　　*105
　＊　　　　　A10003　　　*106
　・　　　　　　　　・　　　　　　・
　・　　　　　　　　・　　　　　　・
　・　　　　　　　　・　　　　　　・

列Bには部品番号が、列Cにはユニット名が記入されています。
同じ部品番号でもユニットが異なる場合には、列Aに*が記入されています。
このようなデータが20,000行ほどあります。

上記のようなデータを以下のように並べ替えたいと考えております。
　列A　　　　列B　　　　　　列C　　　　　列D　　　　　列E
　識別　　　部品番号　　　ユニット　　　ユニット　　ユニット
　　　　　　　A10000　　　　*100
　　　　　　　A10001　　　　*101
　　　　　　　A10002　　　　*102　　　　　*103
　　　　　　　A10003　　　　*104　　　　　*105　　　　　*106

VBAを利用すればできるんだろうなーと思っていますが、
見当もつきません。
どうぞよろしくお願いいたします。

回答No.5

zap35

＞このサンプルをベースにIF文等を加えないと問題は解決できない
ということなのでしょうか？

そうですね。そう思います。
質問文にあるとおりのデータを手で入力して、＃０１さんのマクロを実行すればちゃんと動きます。試されましたか？
それが動かないとすれば「実際のデータには質問文に書かれていない『何か』があるから」ではないでしょうか。

例えば「部品番号が昇順になっていなくて同じ番号が繰り返し出現する」、「一つの部品番号が２５６以上のユニットで利用されている」、「A列の＊は関数で表示している」などです。

実際のデータが分からないのでB列、C列のデータだけで処理するようにしてみました。A列のデータに意味があるならご自身で書き換えてください

Sub Macro1()
Dim ws As Worksheet
Dim idx, ptr As Long
Dim trg As Range
　　Set ws = ActiveSheet
　　On Error GoTo end0
　　Application.ScreenUpdating = False
　　Worksheets.Add after:=ws
　　With ws
　　　　.Rows(1).Copy Destination:=Rows(1)
　　　　For idx = 2 To .Range("B65536").End(xlUp).Row
　　　　　　If .Cells(idx, "B").Value <> "" Then
　　　　　　　　Set trg = ActiveSheet.Columns(2).Find(what:=.Cells(idx, "B").Value, _
　　　　　　　　　　　　　　LookIn:=xlValues, Lookat:=xlWhole)
　　　　　　　　If trg Is Nothing Then
　　　　　　　　　　Range("B65536").End(xlUp).Offset(1, 0).Value = .Cells(idx, "B").Value
　　　　　　　　　　ptr = Range("B65536").End(xlUp).Row
　　　　　　　　Else
　　　　　　　　　　ptr = trg.Row
　　　　　　　　End If
　　　　　　　　If Application.CountIf(Rows(ptr), .Cells(idx, "C").Value) = 0 Then
　　　　　　　　　　If Cells(ptr, "IV").Value = "" Then
　　　　　　　　　　　　Cells(ptr, "IV").End(xlToLeft).Offset(0, 1).Value = _
　　　　　　　　　　　　　　.Cells(idx, "C").Value
　　　　　　　　　　Else
　　　　　　　　　　　　MsgBox "列数が２５６を超えるので処理できません"
　　　　　　　　　　　　Exit For
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　　　Set trg = Nothing
　　　　　　End If
　　　　Next idx
　　End With
end0:
　　Application.ScreenUpdating = True
End Sub

お礼

無事に問題を解決することができました。
ありがとうございました。