| |
A列〜J列までデータがあります。
A列とB列をKEYにしてC列〜J列の値をまとめて、重複してる文字を消したいと考えています。A列〜I列は文字列でJ列が数値です。C列〜I列はセル内が空欄の場合もあります。
現在は下記のコードでそれぞれシートに分けて列をコピーし（<A列B列C列> <A列B列D列>など）、最後に別シートにコピーしてまとめています。
これを元データのまま加工する方法を教えて下さい。
A列 ｜B列 ｜C列 ｜D列 ｜E列 ｜F列 ｜G列 ｜H列 ｜I列 ｜J列
りんご｜いちご｜かき ｜みかん｜ぶどう｜なし ｜すいか｜メロン｜ライチ｜30
りんご｜いちご｜スイカ｜みかん｜ぶどう｜いも ｜すいか｜メロン｜ライチ｜20
りんご｜もも ｜スイカ｜みかん｜ぶどう｜いも ｜すいか｜メロン｜ライチ｜30
↓
りんご｜いちご｜かき・スイカ｜みかん｜ぶどう｜なし・いも｜すいか｜メロン｜ライチ｜50
りんご｜もも ｜スイカ｜みかん｜ぶどう｜いも ｜すいか｜メロン｜ライチ｜30
--------------------------------------------
Sub test()
Dim r As Range, LRng As Range, s1, s2, i As Integer
Dim fAdd As String, flg As Boolean, n As Integer
Application.ScreenUpdating = False '画面ちらつき制御
With ActiveSheet
For Each r In Range("A2", .Range("A" & Rows.count).End(xlUp))
s1 = Array(r.Offset(0, 1).Value)
s2 = Array(r.Offset(0, 2).Value)
For i = 0 To UBound(s1)
'A列の値E列からを探す
Set LRng = .Columns("E:E").Find(What:=r, after:=.Range("E1"), LookAt:=xlWhole)
'A列=E列が無かった場合→転機
If LRng Is Nothing Then
Set LRng = .Range("E" & Rows.count).End(xlUp).Offset(1, 0)
LRng.Value = r.Value
LRng.Offset(0, 1).Value = s1(i)
LRng.Offset(0, 2).Value = s2(i)
Else
'A列=E列があった場合
fAdd = LRng.Address
flg = False
Do
'B列=F列を確認しマッチした場合の処理
If LRng.Offset(0, 1).Value = s1(i) Then
If LRng.Offset(0, 2).Value = "" Then
LRng.Offset(0, 2).Value = s2(i)
ElseIf s2(i) <> "" And InStr(1, LRng.Offset(0, 2).Value, s2(i), 1) = 0 Then
LRng.Offset(0, 2).Value = LRng.Offset(0, 2).Value & "・" & s2(i)
End If
flg = True
Exit Do
End If
Set LRng = .Columns("E:E").FindNext(LRng)
Loop While Not LRng Is Nothing And LRng.Address <> fAdd
'A列=E列は見つかったが、B列=F列がマッチしない場合の処理
If Not flg Then
Set LRng = .Range("E" & Rows.count).End(xlUp).Offset(1, 0)
LRng.Value = r.Value
LRng.Offset(0, 1).Value = s1(i)
LRng.Offset(0, 2).Value = s2(i)
End If
End If
Next i
Next r
End With
End Sub
|
|
やみ
- 11/9/23(金) 15:34 -
