エクセルマクロで比較して消去したり 残したりを

質問

皆様よろしくお願いします。

１行目にタイトルが入っています。
A列とB列にそれぞれ数字が入っていて
その数字を比較してアル規則に基づいて
列をずらしたり　消したりしたいのです、
A　　　B
2　　　1
4　　　2
5　　　3
6　　　5　　　
を
A　　　B
2　　　2
5　　　5　　こういう結果にしたいのです。

A列にもB列にも数字が小さいほうから大きいほうに
並んでいて　それぞれ同じ数字もあれば欠番もあります
(隙間無く並んでます)
同じ行で比較して同じ数字であればそのまま残し
違っていれば上にずらして比べて・・・
という作業です。ちなみにデータ数はAが２０００ほど
Bが５００００ほどです。
なにか良い方法があればお願いいたします。

回答No.6

imogasi · ベストアンサー

＃５に関して。
Maxが使えないのではないかと思います。
であれば、＃４でも書いた
「それでも駄目ならA,B列で最大数に＋１した数をhighv にセットして見てください。」目でみてA列B列の最大値より
大きい数を見繕い、highv=999999999(例えば）を入れて
highv = WorksheetFunction.Max(sh1.Cells(d1, "A"), sh1.Cells(d2, "B")) + 1
の行を削除して、実行して見てください。

お礼

ありがとうございます

おっしゃるとおりにhighvに数値を設定して
highv = WorksheetFunction.Max(sh1.Cells(d1, "A"), sh1.Cells(d2, "B")) + 1　を削除したところ
無事動作いたしました。

Max命令が使えない事まで配慮してくださって
助かりました。
昨日も書きましたが
別シートに結果を書き出す事も重要なのですね

お二方のそれぞれ違う方向からのお答え
ありがとうございました

回答No.7

BLUEPIXY

もう、不要かもしれませんが、一応
Ｃ列対応版
Public Sub AandB()
Dim a As Range, b As Range
Dim aPos, bPos, savePos

Set a = Range("A2")
Set b = Range("B2")
aPos = 0
bPos = 0
savePos = 0
Do While (a.Offset(aPos, 0).Value <> "")
If a.Offset(aPos, 0).Value = b.Offset(bPos, 0).Value Then
a.Offset(savePos, 0).Value = a.Offset(aPos, 0).Value
b.Offset(savePos, 0).Value = b.Offset(bPos, 0).Value
b.Offset(savePos, 1).Value = b.Offset(bPos, 1).Value
If (aPos <> aSavePos) Then
a.Offset(aPos, 0).Clear
b.Offset(bPos, 0).Clear
b.Offset(bPos, 1).Clear
End If
aPos = aPos + 1
bPos = bPos + 1
savePos = savePos + 1
Else
If a.Offset(aPos, 0).Value < b.Offset(bPos, 0).Value Or b.Offset(bPos, 0).Value = "" Then
a.Offset(aPos, 0).Clear
aPos = aPos + 1
Else
b.Offset(bPos, 0).Clear
b.Offset(bPos, 1).Clear
bPos = bPos + 1
End If
End If
Loop
Do While (b.Offset(bPos, 0).Value <> "")
b.Offset(bPos, 0).Clear
b.Offset(bPos, 1).Clear
bPos = bPos + 1
Loop
End Sub

回答No.5

imogasi

＃４の補足に関して
C列の追加。
sh2.Cells(k, "A") = k1
sh2.Cells(k, "B") = k2
のすぐあとに
sh2.Cells(k, "C") = Sh1.Cells(j,"C")を追加。

これと昨日のエラーが出る件とは、関係ないと思います。

こちらが聞いた
「A列かB列の最終行近くのセルに「合計」とか（数字以外が）、入っていませんか」の答えはどうですか。

回答No.4

imogasi

#1です。私のデータでは動きました。と言うことは、質問者のデータでテストしてますね。
●d1,ｄ2はA列、B列の「数字データ」の最下行を掴まえるつもりです。
A列かB列の最終行近くのセルに「合計」とか、入っていませんか。
入っておれば、その行数をマイナスしたものをｄ１、ｄ２にしてください。d1=d1-1などをコードの直下に入れる。
その下に仮にMsgbox d1などを入れて、実行時に表示して、d1,d2の値（数字データの最下行数）が正しいかテストして見てください。
●それでも駄目ならA,B列で最大数に＋１した数をhighv にセットして見てください。
勿論エラーが出た行はコメント化してください。

お礼

たびたびご解答ありがとうございます
お礼が遅くなって申し訳ありません
現在テストできる環境にないので
明日に改めて試させていただき
ご報告いたします

ありがとうございました

補足

おはようございます

昨日の質問自体に間違いがありましたので
訂正させていただきます

１行目にタイトルが入っています。
A列とB列にそれぞれ数字が入っていて
C列にはB列に関する文字が入っています。
データ数はAが50000程BCが2000程です
AとBを比較して同じものを残したいです
(C列の文字も)

大変失礼いたしました

回答No.3

BLUEPIXY

＃２です
タイトルが入っているのを忘れていました。
Set a = Range("A2")
Set b = Range("B2")
にして下さい

お礼

ありがとうございました
先ほど試しましたら無事に動作いたしました。

お二方のそれぞれ別方向からの御回答
非常にたすかりました
ありがとうございます

回答No.2

BLUEPIXY

同じシートでやるバージョンを作ってみました。
元に戻せないので、シートをコピーしてから実行して下さい。
Public Sub AandB()
Dim a As Range, b As Range
Dim aPos, bPos, aSavePos, bSavePos

Set a = Range("A1")
Set b = Range("B1")
aPos = 0
bPos = 0
aSavePos = 0
bSavePos = 0
Do While (a.Offset(aPos, 0).Value <> "")
If a.Offset(aPos, 0).Value = b.Offset(bPos, 0).Value Then
a.Offset(aSavePos, 0).Value = a.Offset(aPos, 0)
If (aPos <> aSavePos) Then a.Offset(aPos, 0).Clear
aPos = aPos + 1
aSavePos = aSavePos + 1
b.Offset(bSavePos, 0).Value = b.Offset(bPos, 0)
If (bPos <> bSavePos) Then b.Offset(bPos, 0).Clear
bPos = bPos + 1
bSavePos = bSavePos + 1
Else
If a.Offset(aPos, 0).Value < b.Offset(bPos, 0).Value Or b.Offset(bPos, 0).Value = "" Then
a.Offset(aPos, 0).Clear
aPos = aPos + 1
Else
b.Offset(bPos, 0).Clear
bPos = bPos + 1
End If
End If
Loop
Do While (b.Offset(bPos, 0).Value <> "")
b.Offset(bPos, 0).Clear
bPos = bPos + 1
Loop
End Sub

お礼

ありがとうございます
imogasi様のご解答とあわせて
試させていただきますね
ありがとうございます

回答No.1

imogasi

（テストデータ）Sheet2に（数字が入っているとします）
（文字だと下記コードは変更を要す。）
A B
2 1
4 2
5 3
6 5
8 6
12 8
13 9
16 10
24 13
16
（結果）Sheet3に
2 2
5 5
6 6
8 8
13 13
16 16
（コード）
Sub test01()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Set sh1 = Worksheets("sheet2")
Set sh2 = Worksheets("sheet3")
highv = WorksheetFunction.Max(sh1.Cells(d1, "A"), sh1.Cells(d2, "B")) + 1
d1 = sh1.Range("A65536").End(xlUp).Row
d2 = sh1.Range("B65536").End(xlUp).Row
i = 2: j = 2: k = 2
p01:
k1 = sh1.Cells(i, "A")
k2 = sh1.Cells(j, "B")
If i > d1 Then k1 = highv
If j > d2 Then k2 = highv
'------
If k1 = k2 Then
If k1 = highv Then GoTo owari
sh2.Cells(k, "A") = k1
sh2.Cells(k, "B") = k2
k = k + 1
i = i + 1: j = j + 1
GoTo p01
'-------
ElseIf k1 > k2 Then
j = j + 1
GoTo p01
'-------
ElseIf k1 < k2 Then
i = i + 1
GoTo p01
End If
owari:
End Sub

＞消去したり　残したりを
＞同じ数字であればそのまま残し、違っていれば上にずらして比べて・

あるシート上で考え・説明し・表現するから、判り難い。
比較は元のシートのデータ上で考え、残したりとかいうのは別シート上で実現すれば良いのです。（定石）
そして上記でよいなら、これはマッチングのロジックと言って、有名・有力なものです。

お礼

御回答ありがとうございます
さっそく使用させていただきましたが
highv = WorksheetFunction.Max(sh1.Cells(d1, "A"), sh1.Cells(d2, "B")) + 1

この部分でエラーになってしまいました
自分で見てみたのですがどこがエラーの原因なのか
分かりません。
もしお手数でなかったらよろしくおねがいいたします。

「同一シートでするから難しい」との助言
思い返せばおっしゃるとおりです
ありがとうございます

補足

昨夜の御回答に関しての報告をいたします

ABそれぞれには先頭のタイトルを除いて
合計などの文字も式も一切はいっていないことを
確認してマクロを動作させましたが
エラーは変わりませんでした
メッセージは
「実行時エラー１００４
アプリケーション定義　またはオブジェクション定義の
エラーです」
でした