エクセル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
お礼
出来ました！！ 素晴しいです！！ありがとうございます。