Excel VBA質問箱 IV

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

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


31629 / 76738 ←次へ | 前へ→

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

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

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