|
自分も一案作ってありましたので、
参考までにUPします
Sub Test()
Dim r As Long, LastR As Long 'ループ用Row,最終行Row
Dim St As Long, En As Long '連番開始の値,終了の値
Dim Wr_R As Range '書き出すRange
With ActiveSheet
Set Wr_R = .Range("E1")
Wr_R.Resize(, 2).EntireColumn.ClearContents
Wr_R.Resize(, 2).EntireColumn.NumberFormatLocal = "@"
St = .Cells(1, 1).Value
LastR = .Cells(Rows.Count, 1).End(xlUp).Row
For r = 1 To LastR
If .Cells(r, 1).Value <> .Cells(r, 1).Offset(1).Value - 1 Or _
.Cells(r, 2).Value <> .Cells(r, 2).Offset(1).Value Then
En = .Cells(r, 1).Value
Wr_R.Value = .Cells(r, 2).Value
Select Case En - St + 1
Case Is = 1
Wr_R.Offset(, 1).Value = CStr(St)
Case Is = 2
Wr_R.Offset(, 1).Value = St & "," & Mid(En, Diff_Left(CStr(St), CStr(En)))
Case Is >= 3
Wr_R.Offset(, 1).Value = St & "〜" & Mid(En, Diff_Left(CStr(St), CStr(En)))
End Select
St = .Cells(r , 1).Offset(1).Value
Set Wr_R = Wr_R.Offset(1)
End If
Next
End With
Set Wr_R = Nothing
End Sub
'Str1とStr2を左から比較。一致しなくなる文字数を返すFunction
Private Function Diff_Left(Str1 As String, Str2 As String) As Integer
Dim i As Integer
For i = 1 To Len(Str1)
If Left(Str1, i) <> Left(Str2, i) Then
Diff_Left = i
Exit Function
End If
Next
Diff_Left = 1 '全て同じなら1を返す
End Function
|
|