Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
5516 / 13646 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【50306】数字をまとめる とも 07/7/19(木) 10:36 質問[未読]
【50309】Re:数字をまとめる ハチ 07/7/19(木) 11:42 発言[未読]
【50312】Re:数字をまとめる ハチ 07/7/19(木) 12:27 発言[未読]
【50314】Re:数字をまとめる とも 07/7/19(木) 13:01 お礼[未読]
【50321】Re:数字をまとめる ハチ 07/7/19(木) 15:08 発言[未読]
【50326】Re:数字をまとめる ちくたく 07/7/19(木) 17:41 回答[未読]
【50330】Re:数字をまとめる ハチ 07/7/19(木) 19:58 発言[未読]
【50346】Re:数字をまとめる ちくたく 07/7/20(金) 13:38 お礼[未読]
【50347】Re:数字をまとめる ちくたく 07/7/20(金) 13:43 発言[未読]
【50356】Re:数字をまとめる ハチ 07/7/20(金) 18:33 回答[未読]
【50306】数字をまとめる
質問  とも  - 07/7/19(木) 10:36 -
引用なし
パスワード
   初心者ですので、出来るかどうかを教えてください。
セルに入っている数字をまとめて表示させたいのです。
例えばA列に数値、B列にグループが入っています。

　A列　　B列
12345　　A
12346　　A
12347　　A
12349　　A
12350　　A
12348　　S
12351　　S
12356　　S
12357　　S

これを「〜」と「,」を使ってグループごとに連続する数値で区切ってまとめて

12345〜7
12349,50
12348
12351
12356,7

と言う風に表示させることは可能でしょうか？
グループごとのソートは出来ています。
同じグループでも「12345〜7,49,50」のように全部はまとめないで、連続しているところだけをまとめたいのです。
よく似たプログラムなどを教えていただくだけでもいいですので、
よろしくお願いします。
【50309】Re:数字をまとめる
発言  ハチ  - 07/7/19(木) 11:42 -
引用なし
パスワード
   ▼とも さん：
>初心者ですので、出来るかどうかを教えてください。
>セルに入っている数字をまとめて表示させたいのです。
>例えばA列に数値、B列にグループが入っています。
>
>　A列　　B列
>12345　　A
>12346　　A
>12347　　A
>12349　　A
>12350　　A
>12348　　S
>12351　　S
>12356　　S
>12357　　S
>
>これを「〜」と「,」を使ってグループごとに連続する数値で区切ってまとめて
>
>12345〜7
>12349,50
>12348
>12351
>12356,7
>
>と言う風に表示させることは可能でしょうか？
>グループごとのソートは出来ています。
>同じグループでも「12345〜7,49,50」のように全部はまとめないで、連続しているところだけをまとめたいのです。
>よく似たプログラムなどを教えていただくだけでもいいですので、
>よろしくお願いします。

回答じゃなくてすいません。
この並びはグループごとにSort(並び替え）されているのですか？
まとめるのは　下2桁のみですか？

パッと見で・・
連続が2個なら　,区切り
3個以上で　〜表記
ですかね？

>12349,50
>12356,7

この下2桁と1桁の場合のロジックを組むのも、
以外と面倒な気がしますね。
12356,57
として良いならもう少し楽かなーと思います。
【50312】Re:数字をまとめる
発言  ハチ  - 07/7/19(木) 12:27 -
引用なし
パスワード
   >>と言う風に表示させることは可能でしょうか？
>>グループごとのソートは出来ています。

>この並びはグループごとにSort(並び替え）されているのですか？

ソートは出来てると書かれてますね
失礼しました。
【50314】Re:数字をまとめる
お礼  とも  - 07/7/19(木) 13:01 -
引用なし
パスワード
   ▼ハチ さん：
目を止めていただきありがとうございました。
いろいろプログラムを作ってみたら、自分で何とか出来そうな感じです。
もう一度考え直して、分からない部分のみを質問するようにします。
やっぱり、丸投げで質問するのは失礼にあたると考え直しました。
また、質問するかもしれませんが、その時は的を得た質問をするようにしますので、
よろしくお願いします。
本当にありがとうございました。
【50321】Re:数字をまとめる
発言  ハチ  - 07/7/19(木) 15:08 -
引用なし
パスワード
   ▼とも さん：
>いろいろプログラムを作ってみたら、自分で何とか出来そうな感じです。
>もう一度考え直して、分からない部分のみを質問するようにします。
>やっぱり、丸投げで質問するのは失礼にあたると考え直しました。
>また、質問するかもしれませんが、その時は的を得た質問をするようにしますので、
>よろしくお願いします。
>本当にありがとうございました。

頑張ってみてください＾＾
失敗しながらいろいろやってみるのが、
上達への近道だと自分は思います。

ちょっとやってみましたが、
〜のあとにつく桁数が変動するとかなり見づらい感じですね・・・
【50326】Re:数字をまとめる
回答  ちくたく E-MAIL  - 07/7/19(木) 17:41 -
引用なし
パスワード
   とも さん
こんにちは。

>初心者ですので、出来るかどうかを教えてください。
やろうと思えば、出来ます、出来ると思います。多分。

ちょっと、書いてみましたが、条件分布がスムーズには書けませんでした。
考え方を変えたら、綺麗に書けるのかもしれませんが、
取りあえず、習作を掲載しておきます。
ただし、特に、以下の点で、仕様を満たしておりません。

・繰り上がりの処理を考えていません。
全てし下二桁で表示しています。
こうすべきところを　こう
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
【50330】Re:数字をまとめる
発言  ハチ  - 07/7/19(木) 19:58 -
引用なし
パスワード
   ▼ちくたく さん：

自分も興味があったので、
Sub Sampleのデータで検証してみたのですが、
いくつか空白の箇所が出てしまいました。

>Case Is <= 2
Case Is >= 2
とすると全てのデータで表示するようになりました＾＾

Sub Sample()
　　Dim r As Long, i As Integer, j As Integer
　　Dim v As Variant
　　With ActiveSheet
　　　　.Cells.ClearContents
　　　　r = 1
　　　　For Each v In Array("A", "B", "C", "D")
　　　　　　For i = 1 To 300
　　　　　　　　Randomize
　　　　　　　　j = CLng(Rnd)
　　　　　　　　If j = 1 Then
　　　　　　　　　　.Cells(r, 1).Value = i + 1000
　　　　　　　　　　.Cells(r, 2).Value = v
　　　　　　　　　　r = r + 1
　　　　　　　　End If
　　　　　　Next
　　　　Next
　　End With
End Sub
【50346】Re:数字をまとめる
お礼  ちくたく E-MAIL  - 07/7/20(金) 13:38 -
引用なし
パスワード
   ハチ さん

こんにちは。

べた書きで、コメントも入っていない汚いコードを、
検証ありがとうございます。

>>Case Is <= 2
>Case Is >= 2
>とすると全てのデータで表示するようになりました＾＾

凡ミスですね。ダメダメですね。
失礼致しました。フォローありがとうございます。

なんか、もうちょっとスムーズに書ける気はするのですが。。。
【50347】Re:数字をまとめる
発言  ちくたく E-MAIL  - 07/7/20(金) 13:43 -
引用なし
パスワード
   自己レスです。

If j + k = UBound(tmp) + 1 Then Exit For
を
If j + k >= UBound(tmp) Then Exit For

とした方がいいのかもしれません。
というか、全体的に見直しは必要ですが。。。
【50356】Re:数字をまとめる
回答  ハチ  - 07/7/20(金) 18:33 -
引用なし
パスワード
   自分も一案作ってありましたので、
参考までにＵＰします

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
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
5516 / 13646 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free