エクセルVBAの修正をお願いいたします。

質問

下記VBAをご教授受けて何とか作りましたが、一行指定で作成したのですが、その時によりデータ数にばらつきがありますので、現状データがあるセルだけを拾ってきてデータのあるなしを、JのセルとKのセルに2種類表示するように作成したつもりですが、データがないセルにも延々と

Jのセルには 1040272
Kのセルには　*
が表示されますのでデータが現状ないセルには何も表示されないようにしたいと思います。
自分でいろいろ調べながらしてみるのですが埒が明かない状態になっておりますので、なにとぞお助け、ご教授をお願いいたします。

わかりにくい説明で申し訳ございませんがなにとぞよろしくお願いいたします。

Range("H2").Select
ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-5],RC[-4])"
Selection.AutoFill Destination:=Range("H2:H10000")
Range("H2:H10000").Select
Columns("H:H").Select
Selection.Copy
Columns("I:I").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.Replace what:="-", Replacement:="", lookat:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace what:="_", Replacement:="", lookat:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Sheets("登録商品リスト").Select
Columns("C:C").Select
Application.CutCopyMode = False
Selection.Copy
Columns("E:E").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.Replace what:="_", Replacement:="", lookat:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace what:="-", Replacement:="", lookat:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("F2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=UPPER(RC[-1])"
Selection.AutoFill Destination:=Range("F2:F10000")
Range("F:F").Select

Columns("F:F").Select
Selection.Copy
Columns("G:G").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Sheet2").Select
Range("J2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=COUNTIFS(登録商品リスト!C[-3],C[-1])"
Selection.AutoFill Destination:=Range("J2:J1500")
Range("J:J").Select

Dim i As Long, endRow As Long, str As String, c As Range, wS1 As Worksheet, wS2 As Worksheet
Set wS1 = Worksheets("登録商品リスト")
Set wS2 = Worksheets("Sheet2")

endRow = wS2.Cells(Rows.Count, "K").End(xlUp).Row
Application.ScreenUpdating = False
If endRow > 1 Then
Range(wS2.Cells(2, "K"), wS2.Cells(endRow, "K")).ClearContents
End If
For i = 2 To wS2.Cells(Rows.Count, "I").End(xlUp).Row
str = Left(wS2.Cells(i, "I"), 5)
Set c = wS1.Range("G:G").Find(what:=str, LookIn:=xlValues, lookat:=xlPart)
If Not c Is Nothing Then
wS2.Cells(i, "K") = "*"
End If
Next i
Application.ScreenUpdating = True

End Sub

回答No.2

tom04 · ベストアンサー

No.1です。

補足を何度も読み返してみたのですが、
間違っていたらごめんなさい。
「登録商品リスト」Sheetも「Sheet2」も1列だけの操作でできそうな感じですので
勝手に↓のコードにしてみました。

「登録商品リスト」のC・D列を結合し、「-」と「_」を消して大文字にしたものをE列に表示！
「Sheet2」のC・D列を結合し、「登録商品リスト」と同様の操作の結果をH列に表示！

「登録商品リスト」のE列の中に「Sheet2」のH列と完全一致するものは
J列に「1」を表示、K列にアスタリクス（*）を表示

「登録商品リスト」SheetのE列の中に「Sheet2」の「H列の頭5文字」と部分一致するものは
J列に「2」を表示、K列にアスタリクス（*）を表示

上記どちらでもないものはJ列に「0」をK列は空白のまま！
というやり方です。

Sub Sample1() 'この行から
Dim i As Long, endRow1 As Long, endRow2 As Long, c As Range, r As Range, str As String
Dim wS1 As Worksheet, wS2 As Worksheet
Set wS1 = Worksheets("登録商品リスト")
Set wS2 = Worksheets("Sheet2")
endRow1 = wS1.Cells(Rows.Count, "C").End(xlUp).Row '←「登録商品リスト」SheetのC列最終行
If endRow1 > 1 Then
Range(wS1.Cells(2, "E"), wS1.Cells(endRow1, "E")).ClearContents
End If
With Range(wS1.Cells(2, "E"), wS1.Cells(endRow1, "E")) '←「登録商品リスト」SheetのE列のみで処理
.Formula = "=UPPER(C2&D2)"
.Value = .Value
.Replace what:="-", replacement:="", lookat:=xlPart
.Replace what:="_", replacement:="", lookat:=xlPart
End With
endRow2 = wS2.Cells(Rows.Count, "C").End(xlUp).Row '←「Sheet2」のC列最終行
If endRow2 > 1 Then
Range(wS2.Cells(2, "H"), wS2.Cells(endRow2, "H")).ClearContents
End If
With Range(wS2.Cells(2, "H"), wS2.Cells(endRow2, "H")) '←「Sheet2」のH列のみで処理
.Formula = "=UPPER(C2&D2)"
.Value = .Value
.Replace what:="-", replacement:="", lookat:=xlPart
.Replace what:="_", replacement:="", lookat:=xlPart
End With
For i = 2 To endRow2
With wS2.Cells(i, "J")
str = Left(wS2.Cells(i, "H"), 5) '←「Sheet2」のH列頭5文字を格納
Set c = wS1.Range("E:E").Find(what:=wS2.Cells(i, "H"), LookIn:=xlValues, lookat:=xlWhole)
Set r = wS1.Range("E:E").Find(what:=str, LookIn:=xlValues, lookat:=xlPart)
If Not c Is Nothing Then '←「登録商品リスト」SheetのE列に完全一致するデータがあれば
.Value = 1 '←J列に「1」を表示
.Offset(, 1) = "*" '←K列に「*」を表示
ElseIf Not r Is Nothing Then '「登録商品リスト」SheetのE列に部分一致（頭5文字）があれば
.Value = 2 '←J列に「2」を表示
.Offset(, 1) = "*" '←K列に「*」を表示
Else
.Value = 0 '←完全一致・部分一致どちらもなければ「0」を表示
End If
End With
Next i
End Sub 'この行まで

※　質問文のコードでは10000行までオートフィルしているようですが、
どちらのSheetもC列の最終行まで！というコトにしています。

的外れならごめんなさいね。m(_ _)m

お礼

tomo04さん
本当にありがとございます。
一つ一つ作業を確認しながらバラバラに作成したものを組み上げてましたので無駄が多い部分も作業を簡潔にしていただきありがとうございました。

完ぺきにできました。
また、説明を付けていただきましたのでとてもありがたく、今後の参考にもなります。

イロイロ便利にと考えておりますので、また、お世話になることもあろうかと思いますがその時はよろしくお願いいたします。

　カープの来年の活躍を祈っています。
ドラフトでよい選手が取れますように祈っています。

回答No.1

tom04

こんばんは！

http://okwave.jp/qa/q8309495.html
↑のURLで最後の部分を回答した者です。

それまでのコードを拝見して、結局何をしたいのか見えてこないのですが・・・
コードではF・H列は10000行目まで数式をオートフィルしていて、
J列だけは1500行目までですね？
そして
＞ActiveCell.FormulaR1C1 = "=COUNTIFS(登録商品リスト!C[-3],C[-1])"
の「COUNTIFS関数」の使い方がおかしいように思えるのですが・・・
（検索範囲だけで「検索条件」が指定されていないとみれます）

おそらくこの関数のおかげ？で意図しない結果が表示されているのでは？

※　コードを詳しく検証していませんので
どのようなコトをやりたいのか！という部分が理解しかねますので
（判る人が見れば判るのだとおもいますが、今は気力がありません。カープも早々と負けたことですし）

この程度でごめんなさいね。m(_ _)m

補足

早々のアドバイスありがとうございます。
詳しく書かず、いきなりコードだけの質問で申し訳ないです。

今回作成したいと思っているものは、

Sheet1→登録商品リスト
Sheet2→Sheet2

上記2枚のシートを使用してデータのチェックをしたいと思っています。

Sheet1の方には、最低限チェックするのに必要なデータが”A”~”D”まで入っていて
”E”のセルには”C”の列に入っている商品コードを”-”や”_”を抜いた形のコードが入力されるようにしています。
”F”のセルには"E”の商品コードがすべて大文字になるように設定しています。
”G”のセルには”F”のセルのデータの値が貼り付けられるようにしています。
上記がShhet1＝登録商品リストの内容です。
また登録商品リストの方には日々商品が追加されていきます。

Sheet2には前日に動いた商品のデータを入力されているのですが、
”A"~”G"までは前日に動いた商品の品番とかが入っています。
”H"のセルには”C"のデータと”D"のデータを結合したものが入力されるように設定しています。
”I"のセルには”H"のセルの値を入力が入力され、なおかつ”-””_”が除かれる設定をしています。
”J"のセルには”登録商品リスト”の”G"のセルの内容と”I"のセルの内容の完全一致データに”1”、ないデータには”0”が入るようにチェックできるようにしました。
このままだと、チェック漏れする商品コードがありましたので、前回何とか解消すべくコードをお伺いいたしました。
前回お伺いしたコードの結果が”K"に反映されるようにしました。
あいまい検索と完全一致の両方の結果を合わせますとほぼ完ぺきに商品コードを拾うことができます。

私の力不足で本来なら現状あるデータだけの結果を”J""K"の列に表示させたいのですが、アルファベットの列の一行指定をしてしまうとコードにエラーが出るので1500、10000ととりあえず行数指定をしている次第です。

自分でもよくわからなくなってしまい質問致しました。

わかりづらく申し訳ないです。

育成のカープ、これから良い選手が続々育ち日本一になる日も近いと思います。