エクセル 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.1

xls88 · ベストアンサー

サンプルです。

Sub Macro()
　　Dim rng As Range
　　Dim i As Long
　　Dim j As Long

　　Set rng = Range("A3", "A" & Range("B" & Rows.Count).End(xlUp).Row)
　　Set rng = rng.SpecialCells(xlCellTypeConstants, 2)
　　For i = 1 To rng.Areas.Count
　　　　For j = 1 To rng.Areas(i).Count
　　　　　　With rng.Areas(i).Item(j)
　　　　　　　　.Offset(-j, j + 2).Value = .Offset(, 2).Value
　　　　　　End With
　　　　Next j
　　Next i
　　rng.EntireRow.Delete
End Sub

＞VBAを利用すればできるんだろうなーと思っていますが、
＞見当もつきません。
手作業ではどうしますか？
手作業を「マクロの記録」すれば参考コードが得られます。

お礼

さっそくのご回答ありがとうございます。

このサンプルを実行すると、
C列のデータが一行目のD列から最終列（IV列）まで転写され
エラーメッセージが出てしまいます。

私のやり方がどこかまずいのでしょうか？
それともサンプルはあくまでもサンプルであり、
このサンプルをベースにIF文等を加えないと問題は解決できない
ということなのでしょうか？

重ね重ねの質問で申し訳ありませんがよろしくお願い致します。

回答No.8

xls88

Wendy02さん
＞rng.Columns(1).Value = rng.Columns(1).Value
「参考になった」ボタンをClickしました。
ありがとうございました。

""以外に、スペース、Alt＋Enter、CHAR(10)等にも対応できないか考えてみました。
nankoro_xさんの補足によれば「＊」セル以外は「空白」セルという認識で問題ないようです。
「セル選択」で「選択オプション」にある「アクティブ列との相違」を利用し

Dim frng As Range

Set rng = Range("A4", "A" & Range("B" & Rows.Count).End(xlUp).Row)
With rng
　　Set frng = .Find(what:="＊", After:=.Cells(.Count), LookIn:=xlValues)
End With
rng.ColumnDifferences(frng).ClearContents
Set rng = rng.SpecialCells(xlCellTypeConstants, 2)

と、こんな風にしてみましたが、どうでしょうか。

回答No.7

Wendy02

xls88さん
nankoro_xさん

こんばんは。

xls88さん、私の書いたものを読んでいただきありがとうございました。
#1のコードを試して、私が試した方法は、一旦、数式を作っておいて、それを値貼り付けしてみました。目では、"" は消えているのですが、SpecialCells を試してみると、Area が、ひとつにまとまってしまいました。

そこで、私の一案ですが、

Set rng = Range("A3", "A" & Range("B" & Rows.Count).End(xlUp).Row)　
rng.Columns(1).Value = rng.Columns(1).Value '←このコードを入れてみました。
Set rng = rng.SpecialCells(xlCellTypeConstants, 2)

私の作ったサンプルの場合は、成功しました。
ご質問者さんに対しては、必ず上手くいくとは保証できないのですが、「"" 」残っている場合は、.Value = .Value で消せるのです。

お礼

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

回答No.6

xls88

＞先ほどのプログラムの意味を調べる所から始めてみます。
是非そうしてください。
その姿勢があれば、必ずVBAの使い手として上達されると思います。
解らないところがあれば、遠慮なく補足してください、解る範囲でお答えしたいと思います。

私が提示したコードは、A列で、文字（「＊」に限らない）が入力されているセルを抽出し、その後の処理の基準にしています。
問題は、Wendy02さんが指摘されているように、空白セルは、実は空白ではなく空白に見えているセルだということだと思います。
1行目ではなく、2行目に転記されるということは、A2セルのみ真正の空白セルだと思います。

先のコードに、★のところを追加してみてください。

Set rng = rng.SpecialCells(xlCellTypeConstants, 2)
MsgBox rng.Address　'★

実行すると、メッセージボックスにセル範囲アドレスが表示されます。
空白に見えるセルが、表示されたセル範囲に含まれていると思います。
対応策が、他の方々から提案されています。参考にしてください。
他には、検索で、＊セルを抽出する手もあるとおもいます。

ご存知かもしれませんが
VBEのコードウィンドウで、調べたい単語の中に文字カーソルを置いた状態で、F1キーを押してください。
目的の単語のページにジャンプして、ヘルプが表示されます。

デバッグについて
http://members.jcom.home.ne.jp/rex-uchida/vba110.htm
ブレークポイント
http://www.vba-world.com/breakpoint.html

お礼

いろいろとご教授頂きありがとうございます。

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

A列ですが、
=IF(COUNTIF($B$2:B2,B2>1),"*","")
という関数で二個目以降の同一部品番号に*をつけた後、
値コピーしたものです。
値コピーすれば空白か*のみになると考えておりました。
私の前提条件の提示が足りませんでした。
申し訳ございませんでした。

xls88様のコードに、Wendy02様の提示された1行を追加したところ
うまくいきました。
本当にありがとうございました。

回答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

お礼

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

回答No.4

Wendy02

こんにちは。

まず、#1さんのコードは、問題ないはずなのですが、その「識別」が付けられた過程を考えたときに、数式でできていたのではないでしょうか。仮に、文字として、定数になっていても、空白部分が完全に空白になっていないのではないか、と思います。値貼り付けでは、どうやら痕跡が残るようですから、SpecialCells　以外のマクロによる、完全空白する処理が必要かもしれません。

そこで、私は、その質問の表を見たときに、その「識別」をまったくアテにしないことを考えました。2万行ということになると、最後まで信頼置けないような気がしました。そこで、「識別」を頼りにせず、独自に、配列で確保しながら、配列を使って、表を作ることにしました。データが、20,000件ですから、まあ、そこそこに動くレベルだと思います。それ以上のスピードを稼ぐものは、あまり思い当たらないです。

以下は、シート2に書き出すようにはなっていますが、その設定は、任意にしてください。

Sub ArrangeLines()
　　'部品番号はソートされていることが条件
　　Dim sh1 As Worksheet
　　Dim sh2 As Worksheet
　　Dim rng As Range
　　Dim i As Long, j As Long, k As Long
　　Dim mx As Integer
　　Dim v As Variant
　　Dim ar As Variant
　　Dim ar2 As Variant
　　Dim art()
　　Dim arb() As String
　　Dim buf As String
　　Dim flg As Boolean
　　'-------------------------------------------
　　Set sh1 = Worksheets("Sheet1") 'オリジナル・データシート
　　Const O As String = "A1" 'オリジナルデータの左上端

　　Set sh2 = Worksheets("Sheet2") 'データの書き出しシート
　　Const P As String = "A1" 'データの書き出し場所端
　　'-------------------------------------------
　　With sh1
　　　　Set rng = .Range(O).Range("B1", .Range("B65536").End(xlUp))
　　End With
　　sh2.Range(P).CurrentRegion.ClearContents
　　ar = Application.Transpose(rng.Offset(1).Value)
　　ar2 = Application.Transpose(rng.Offset(1, 1).Value)

　　For i = LBound(ar) To UBound(ar) - 1
　　　　If buf = "" Then
　　　　　　buf = Trim(ar(i))
　　　　End If
　　　　If ar(i) <> ar(i + 1) Then
　　　　　　buf = buf & "," & ar2(i)
　　　　　　j = j + 1
　　　　　　ReDim Preserve art(j)
　　　　　　flg = True
　　　　Else
　　　　　　buf = buf & "," & Trim(ar2(i))
　　　　End If
　　　　If flg Then
　　　　　　k = Len(buf) - Len(Replace(buf, ",", ""))
　　　　　　If mx < k Then
　　　　　　　　mx = k
　　　　　　End If
　　　　　　art(j) = buf
　　　　　　buf = ""
　　　　　　flg = False
　　　　End If
　　Next i
　　ReDim arb(mx, UBound(art))
　　j = 0
　　For i = LBound(art) To UBound(art)
　　　　If Not IsEmpty(art(i)) Then
　　　　　　For Each v In Split(art(i), ",")
　　　　　　　　arb(j, i - 1) = v
　　　　　　　　j = j + 1
　　　　　　Next v
　　　　End If
　　　　j = 0
　　Next i
　　With sh2
　　　　If k > 256 - Range(P).Row - 1 Then k = 256 - Range(P).Row - 1 'Ver.2003 まで
　　　　sh1.Range(O).Resize(, 3).Copy .Range(P)
　　　　.Range(P).Offset(, 2).Copy .Range(P).Offset(, 3).Resize(, k - 1)
　　　　.Range(P).Offset(1, 1).Resize(UBound(arb, 2) + 1, k + 1).Value = _
　　　　Application.Transpose(arb())
　　End With

End Sub

お礼

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

回答No.3

imogasi

>見当もつきません。
表の体裁の組み換え（ＶＢＡで）は結構難しく中級以上の者の課題です。まだ早すぎる。だから丸投げになってしまうが、本質問コーナーに回答者にコードを書かせるのは規約違反です。下請け機関ではない。
ーー
本件には、ソート法が良かろう。
Ａ１００２の行を処理しているとき、次にＡ１０００が出てきては困るからです。結果表を見れば判るとおり、
部品番号＋ユニットの順に出てきてほしいのでその２列で昇順にソートする。同じ部品番号で同じユニットが複数出てくるのか質問に書いてないが、重要ポイントで、経験のなさを示している。無いとして、
Ｓｈｅｅｔ２の列Ｃ、数字で言うと３からＳｈｅｅｔ１を１行読むごとにＳｈｅｅｔ２の列に順次ずらして書き出す。そのためには、書き出す列を示すポインター（変数）を持つ。Ｓｈｅｅｔ１の１行読むごとに、ポインターを＋１する。しかし
Ｓｈｅｅｔ１で部品番号が変わったら、ポインターをＣ列数字で３にリセットする。
そのために直前の部品番号を記憶する変数を作り、次の行を呼んだとき毎回前行と比較して、変わったか判定する。
（Ａ）部品番号が変わった
次行をさす。そして列はＣ列　に書く
（Ｂ）部品番号が変わらない
右隣列　に書く
＝＝
ほかに
●Cells（i、j）の使い方知ってますか。
●最終行まで上記の処理を繰り返しますが、最終行の捉え方を知ってますか。
●現データと別の他シートへ結果表（Sheet2）書き出すを希望するなら
その表現法（コード）を知ってますか。
判らないなら、人のコードを盗めば何てこと無いものだが、判らないまま使うということになる。こういう本番のずっと前に、日ごろから後日に備え、他人の書いたコードを勉強して、頭に整理して無いと出来ないのです。

お礼

おっしゃる通りだと思います。
今回の教訓を糧に勉強に勤しみます。
ありがとうございました。

回答No.2

xls88

提示された例題が、現状をありのままに表現されていればサンプルでも結果が得られるはずです。
もしかすると、A列に空白セルはなく、＊以外のデータで埋まっているということでしょうか？
もし例題が仮定だとすると、実際に合わせて編集する必要があります。
編集できないのなら、実際の情報を現状に則して提供してみてください。

お礼

さっそくのご回答ありがとうございます。

実行結果ですが、先ほどは1行目のD列から・・・と
記述いたしましたが、2行目のD列からの間違いでした。
申し訳ございません。

実際のデータも例と同じく、
1行目のA列に"識別"、B列に"部品番号"、C列に"ユニット"と見出しがあり、
データは2行目から始まっています。
また、A列は空白セルか＊しかありません。

先ほどご教授頂きましたプログラムの意味が理解できていないので、
どこが問題なのか全く把握できていないのが現状です。
自分で理解しようともせずに
xls88様にあまりにも丸投げしていましたので、
先ほどのプログラムの意味を調べる所から始めてみます。
ありがとうございました。