エクセルマクロでデータ集約

質問

エクセルで以下の（１）のようなデータを（２）のように整理したいと思っています。

（１）
Ａ列　　　Ｂ列
1　　　1000
1　　　1000
1　　　1000
1　　　1001
1　　　1002
1　　　1002
2　　　1003
3　　　1004
1　　　1005
2　　　1006
3　　　1007
3　　　1008

（２）
Ａ列　　　Ｂ列
1　　　1000～1002・1005
2　　　1003・1006
3　　　1004・1007・1008

以下のような条件です。
１．A列、B列それぞれで重複する値を削る。
２．A列が同じ値は、B列の値をまとめる。
３．区切りに“・”または“～”を使用する。
　1000～1003のようにまとめる。
　“～”の間に値が入らない場合は、1007～1008とはせず、1007・1008とする。

何をどうしてよいか分からず…、すみません。
宜しくお願いします！

回答No.6

Wendy02 · ベストアンサー

#3の回答者です。

97 用のSplit 関数を作りました。
エラーの出た

前回：For Each v In Split(a, ",")
　　　　↓
For Each v In Ex97Split(a, ",")

に置き換えればよいはずです。ですが、それだけで済むか、あまり自信がありませんね。

なお、私のコードの場合は、最初の並べ替えは必要ありません。

同じ場所においてください。

----------------------------------------------------------------------
Private Function Ex97Split(ByVal strText As String, _
　　　　　　　　　　　　　 Optional delim As String = ",")
　　'strText文字列, delim はデリミタ
　　Dim ar() As Variant
　　Dim i As Long
　　Dim j As Long
　　Dim n As Integer
　　Dim buf As Variant
　　If strText = "" Then
　　　　ReDim ar(0)
　　　　Ex97Split = ar()
　　　　Exit Function
　　End If
　　If InStr(strText, delim) = 0 Then
　　　　ReDim ar(0)
　　　　ar(0) = strText
　　　　Ex97Split = ar()
　　　　Exit Function
　　End If
　　i = 1
　　j = 0
　　Do
　　　　j = InStr(i, strText, delim)
　　　　If j = 0 Then
　　　　　　buf = Mid(strText, i)
　　　　　　ReDim Preserve ar(n)
　　　　　　ar(n) = buf
　　　　　　Exit Do
　　　　End If
　　　　buf = Mid(strText, i, j - i + 1 - Len(delim))
　　　　ReDim Preserve ar(n)
　　　　ar(n) = buf
　　　　n = n + 1
　　　　i = j + Len(delim)
　　　　buf = ""
　　Loop
　　Ex97Split = ar()
End Function

お礼

こんにちは。ありがとうございます。
97で動きました！すごっ！

またしても理解していませんが、これから勉強していきます。

回答No.7

imogasi

＃５です。質問どおりの内容の回答。
Sub test02()
d = Range("A65536").End(xlUp).Row
' MsgBox d
'--初期化
k = 10
m = Cells(2, "A")
n = Cells(2, "B")
p = Cells(2, "B")
Cells(10, "F") = Cells(2, "A")
s = Cells(2, "B")
'--各行繰り返し
For i = 3 To d
If Cells(i, "A") = m Then
'--A列変わらない場合
If Cells(i, "B") = n Then GoTo p01
'--B列変わらない場合は何もしない
'--B列が変わった場合
'--整形
If Cells(i, "B") = p + 1 Then '直前から１増えた場合なら
'--続いているなら
If Right(s, 1) = "～" Then '前が～なら何もしない
Else
s = s & "～" '～を加える
End If

Else
'--断絶していたら
If Right(s, 1) = "～" Then '前が～なら
s = s & p & "," & Cells(i, "B") '終わりと、次ぎの初めセット
Else
s = s & "," & Cells(i, "B") ',と最初の数を加える
End If
End If
p = Cells(i, "B")
Else
'--前の行分セット
Cells(k, "G") = s
k = k + 1 '1行下へ
Cells(k, "F") = Cells(i, "A") 'A列セット
s = Cells(i, "B") '最初分で初期化
p = Cells(i, "B")
End If
p01:
'--次ぎ処理への備え
m = Cells(i, "A") '直前は今の番号をセット
n = Cells(i, "B") '直前は今の番号をセット
Next i
'--溜め込み分吐き出し
Cells(k, "G") = s
End Sub
希望されている表示のための整形のところのコードが結構ごたごたした結果になって、なにか良いロジックでで、整形の
部分がすっきり処理できないかと思っています。

回答No.5

imogasi

＞何をどうしてよいか分からず…、すみません
丸投げになって、意味もわからず、自分なりにあわせて修正も出きず
になりませんか。高望みしすぎで、もっと勉強してから考えるべきです・
VBAを考えるとき
（１）エクセルの知識を投影しつつ、どういうロジック（筋道）で化mンガ得ると良いか。
これは図や要や文章で考え表現する。
（２）それを実現するコードはどうなるるか（通常はその一部がどうしたらよいか判らない＝＞質問となる）
ーー
回答は既に出ているが、
本件ではコードを短くを主義に、ソート法で考えてみる。
（１）シートをソートする。原本が必要なら、シートをコピーする。
これはVBAでもできるが、人手操作で済ます。
（２）A列について、値が前行と変わったら
次ぎの行に書き出す。変わらないときは、同行に書き出す。
同じ番号は読み飛ばす。
（３）次にご希望の面倒な、見せ方の修正をする。
ーーー
例データ
Ａ列 Ｂ列
1 1000
1 1000
1 1000
1 1001
1 1002
1 1002
2 1003
3 1004
1 1005
2 1006
3 1007
3 1008
1 1002
2 1003
3 1000
4 1010
3 1012
4 1012
ソート後
Ａ列 Ｂ列
1 1000
1 1000
1 1000
1 1001
1 1002
1 1002
1 1002
1 1005
2 1003
2 1003
2 1006
3 1000
3 1004
3 1007
3 1008
3 1012
4 1010
4 1012
VBAコード標準モジュールに
Sub test01()
d = Range("A65536").End(xlUp).Row
' MsgBox d
k = 2
l = 8
m = Cells(2, "A")
Cells(2, "F") = Cells(2, "A")
For i = 2 To d
If Cells(i, "A") = m Then
If Cells(i, "B") = n Then GoTo p01
Else
k = k + 1
l = 8
Cells(k, "F") = Cells(i, "A")
End If
Cells(k, l) = Cells(i, "B")
l = l + 1
m = Cells(i, "A")
n = Cells(i, "B")
p01:
Next i
End Sub
結果　セル別分離で
1 1000 1001 1002 1005
2 1003 1006
3 1000 1004 1007 1008 1012
4 1010 1012
ーーー
文字列に整形は後刻挙げる。

お礼

こんにちは。回答ありがとうございます。
>通常はその一部がどうしたらよいか判らない＝＞質問となる
おっしゃる通りです。
勉強不足の上、高望みは自覚していました。
丁寧に筋道を立てて書いてくださり、本当に有り難うございます。

…ところで、お名前は“芋菓子”さんなのでしょうか？？

回答No.4

Wendy02

#3の回答者です。

もしかして、Excel97 ですか？
本当は、Excel97は、サポート外なのですが、もしも、その一箇所だけなら、ちょっと考えて見ますが、97は、他にも問題が出そうな気がしますね。OS は、Windows ME とか？

お礼

Excel97でしたが、2000で試しました。
動きました！
考えて頂き、本当にありがとうございました！

道のゴミを分別回収に出すことで、お礼に代えさせていただきます。
では行って参ります。

回答No.3

Wendy02

こんばんは。

>３．区切りに“・”または“～”を使用する。
>　1000～1003のようにまとめる。
>　“～”の間に値が入らない場合は、1007～1008とはせず、1007・1008とする。

こういうリクエストって、ちょっと欲張りのような気もしますね。（^^;　単に、集計だけなら、Dictionaryオブジェクトを使えば、それだけで簡単に済むのですが、コードとしては、倍以上の手間が掛かります。

'[標準モジュール]
'-----------------------------------------------

Sub PickUpNumbers()
　　Dim myDic As Object
　　Dim myData As Variant
　　Dim myItem As Variant
　　Dim i As Long
　　Dim j As Long
　　Dim it As Variant
　　Dim ky As Variant

　　Dim Sh1 As Worksheet
　　Dim Sh2 As Worksheet

　　Set Sh1 = Worksheets("Sheet1")　'シート1
　　Set Sh2 = Worksheets("Sheet2")　'シート2

　　Set myDic = CreateObject("Scripting.Dictionary")
　　With Sh1
　　　　myData = .Range("A1", .Range("A65536").End(xlUp)).Resize(, 2).Value
　　　　For i = 1 To UBound(myData, 1)
　　　　　　If myDic.Exists(myData(i, 1)) Then
　　　　　　　　If InStr(myDic.Item(myData(i, 1)), myData(i, 2)) = 0 Then
　　　　　　　　　　myDic.Item(myData(i, 1)) = myDic.Item(myData(i, 1)) & "," & _
　　　　　　　　　　CStr(myData(i, 2))
　　　　　　　　End If
　　　　　　Else
　　　　　　　　myDic.Add myData(i, 1), CStr(myData(i, 2))
　　　　　　End If

　　　　Next i
　　End With
　　it = myDic.Items
　　ky = myDic.Keys
　　it = ReArrange(it)
　　With Sh2
　　　　Application.ScreenUpdating = False
　　　　For j = 1 To myDic.Count
　　　　　　.Cells(j, 1).Value = ky(j - 1)
　　　　　　.Cells(j, 2).Value = "'" & it(j - 1)
　　　　Next j
　　　　Application.ScreenUpdating = True
　　End With
　　Sh2.Activate
　　Set myDic = Nothing
　　Set Sh1 = Nothing
　　Set Sh2 = Nothing
End Sub

Private Function ReArrange(ByVal BaseArray As Variant)
'リスト、纏め上げ
'1000～1002・1009～1011
　　Dim v As Variant
　　Dim i As Long
　　Dim j As Long
　　Dim a As Variant
　　Dim b As Variant
　　Dim s As Variant
　　Dim t As String
　　b = ""
　　s = ""

　　For Each a In BaseArray
　　　　j = 1
　　　　For Each v In Split(a, ",")
　　　　　　If s = "" Then
　　　　　　　　s = v
　　　　　　ElseIf CLng(s) + j = v And j = 1 Then
　　　　　　　　b = s & "・" & v
　　　　　　　　v = ""
　　　　　　　　j = j + 1
　　　　　　ElseIf CLng(s) + j = v Then
　　　　　　　　b = s & "～" & v
　　　　　　　　v = ""
　　　　　　　　j = j + 1
　　　　　　Else
　　　　　　　　If b = "" Then
　　　　　　　　　　t = t & "・" & s
　　　　　　　　Else
　　　　　　　　　　t = t & "・" & b
　　　　　　　　　　b = ""
　　　　　　　　End If
　　　　　　　　s = v
　　　　　　　　j = 1
　　　　　　End If
　　　　Next v
　　　　If b <> "" Then
　　　　　　t = t & "・" & b
　　　　ElseIf s <> "" Then
　　　　　　t = t & "・" & s
　　　　End If

　　　　BaseArray(i) = Mid(t, 2)

　　　　b = ""
　　　　s = ""
　　　　t = ""
　　　　i = i + 1
　　Next a
　　ReArrange = BaseArray
End Function

お礼

こんばんは。回答ありがとございます。
>ちょっと欲張りのような気もしますね。（^^;

(_ _(--;(_ _(--; ペコペコ

理解せぬまま（すいません）、さっそくコピー＆ペーストさせて頂きました。
Splitのところで、
コンパイルエラー
SubまたはFunctionが定義されていません。
と表示されました。
またしてもどうしてよいかわからず、、、申し訳ありません！！！
宜しくお願いします！

回答No.2

noname#192382

Ｎｏ1です。追加です。
計算に入る前に並び替えを行っています。Ａを第1、Ｂを第2要因にして昇順に並び替えをやっています。

お礼

こんばんは。回答ありがとございます。
おおおーーー、綺麗に並びますね。美しい！

回答No.1

noname#192382

下のようなマクロでほぼご希望の集約ができます。お試しください。

Sub Macro1()
'
' Macro1 Macro
' マクロ記録日 : 2007/10/4 ユーザー名 :
'

'
Dim i1gyo, i2gyo, jretu As Integer
i2gyo = 1
jretu = 2
For i1gyo = 1 To 12
Sheets("Sheet1").Select
dataa = Cells(i1gyo, 1)
datab = Cells(i1gyo, 2)
Sheets("Sheet2").Select
tgyo = i1gyo + 10
If dataa > Cells(i2gyo, 1) Then
jretu = 2
i2gyo = i2gyo + 1
Cells(i2gyo, 1) = dataa
Cells(i2gyo, jretu) = datab
ElseIf datab > Cells(i2gyo, jretu) Then
jretu = jretu + 1
Cells(i2gyo, jretu) = datab
Else
End If
Next i1gyo
End Sub