エクセル マクロ 1列の中にあるデータを抽出し、重複データは削除し、 番号の小さい順に並べて、1つのセルに「，」で繋ぎ表示したい。 セル内には改行されて、複数入っているものもあります。 エクセルのマクロで出来ますでしょうか？ 現状は、セル内に１つだけのデータなので、こちらを改良したいとおもっています。 詳細は、添付資料を参照願います。 回答、よろしくお願い致します。 Sub sample() Dim target As Range, rng As Range Dim lastrow As Long, p As Long Dim st1 As String, st2 As String '列を指定する。 On Error Resume Next Set rng = Application.InputBox(Prompt:="セルを指定してください。", Type:=8) On Error GoTo 0 If Not rng Is Nothing Then '原データを作業表にコピー lastrow = Cells(Rows.Count, rng.Column).End(xlUp).Row If lastrow >= 2 Then Set rng = Range(Cells(2, rng.Column), Cells(lastrow, rng.Column)) rng(rng.CountLarge).Offset(3, 2).Resize(rng.CountLarge).Value = rng.Value Set target = rng(rng.CountLarge).Offset(3, 2).Resize(rng.CountLarge) End If End If '条以降を3桁で表示 For Each rng In target p = InStr(rng.Value, "条") If p <> 0 Then st1 = Left(rng.Value, p - 1) st2 = Right("000" & Mid(rng.Value, p + 1, 99), 3) rng.Value = st1 & "条" & st2 End If Next '並べ替え With ActiveSheet.Sort .SortFields.Clear .SortFields.Add2 Key:=target, SortOn:=xlSortOnValues, _ Order:=xlAscending, DataOption:=xlSortNormal .SetRange target.Offset(1).Resize(target.Rows.Count - 1) .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With '重複を削除 target.RemoveDuplicates Columns:=1, Header:=xlYes '条以降の桁を復旧 For Each rng In target p = InStr(rng.Value, "条") If p <> 0 Then st1 = Left(rng.Value, p - 1) st2 = Val(Mid(rng.Value, p + 1, 99)) rng.Value = st1 & "条" & st2 End If Next 'E10セルに転記 'TEXTJOINを使う場合 Range("E10") = WorksheetFunction.TextJoin("，", True, _ target.Offset(1).Resize(target.Rows.Count - 1)) 'TEXTJOINを使わない場合 'st1 = "" 'For Each rng In target.Offset(1).Resize(target.Rows.Count - 1) 'If rng <> "" Then 'st1 = st1 & rng.Value & "，" 'End If 'Next 'If Right(st1, 1) = "，" Then 'st1 = Left(st1, Len(st1) - 1) 'End If 'Range("E10") = st1 End Sub
