| |
とも さん
こんにちは。
>初心者ですので、出来るかどうかを教えてください。
やろうと思えば、出来ます、出来ると思います。多分。
ちょっと、書いてみましたが、条件分布がスムーズには書けませんでした。
考え方を変えたら、綺麗に書けるのかもしれませんが、
取りあえず、習作を掲載しておきます。
ただし、特に、以下の点で、仕様を満たしておりません。
・繰り上がりの処理を考えていません。
全てし下二桁で表示しています。
こうすべきところを こう
123456,7 123456,57
Sub グルーピング()
Dim d As Object
Dim w As Worksheet, nw As Worksheet
Dim i As Integer, j As Integer, k As Integer
Dim myItems As Variant, myKeys As Variant
Dim tmp As Variant
Dim rNum As Integer
Dim fl As Integer
Dim comp As Integer
'連想配列のために辞書を作成
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To Range("B65536").End(xlUp).Row
If d.Exists(Range("B" & i).Value) = False Then
d.Add Range("B" & i).Value, Range("A" & i).Value
Else
d.Item(Range("B" & i).Value) = _
d.Item(Range("B" & i).Value) & "," & _
Range("A" & i).Value
End If
Next i
'ここから書き出し
Set nw = Worksheets.Add(After:=Worksheets(Worksheets.Count)): nw.Name = "結果整理"
rNum = 1: fl = 0
With nw
myKeys = d.keys
myItems = d.items
For i = LBound(myKeys) To UBound(myKeys)
tmp = Split(myItems(i), ",")
For j = LBound(tmp) To UBound(tmp)
comp = tmp(j)
For k = 1 To UBound(tmp) - 1
If j + k = UBound(tmp) + 1 Then Exit For
If tmp(j + k) - comp = 1 Then
fl = fl + 1
comp = comp + 1
Else
Exit For
End If
Next k
Range("A" & rNum) = myKeys(i)
Select Case fl
Case 0
Range("B" & rNum) = tmp(j)
Case 1
Range("B" & rNum) = _
tmp(j) & "," & Right(tmp(j + 1), 2)
Case Is <= 2
Range("B" & rNum) = _
tmp(j) & "〜" & Right(tmp(j + k - 1), 2)
End Select
j = j + k - 1: rNum = rNum + 1: fl = 0
Next j
Next i
End With
End Sub
|
|
ちくたく
- 07/7/19(木) 17:41 -
