Excel VBA質問箱 IV

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

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


5515 / 13645 ツリー ←次へ | 前へ→

【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 -

引用なし
パスワード
   自分も一案作ってありましたので、
参考までに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

5515 / 13645 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free