'日付数字の位置をそろえるマクロ

'セル範囲を選択し、UniformDateFormatマクロを実行してください。

Option Explicit

Const myTitle As String = "日付位置そろえ"

Sub UniformDateFormat()
    Dim a(0 To 7) As String
    Dim r As Range
    Dim s As String
    Dim v As Variant
    Dim obj As Object
    Dim stat As Integer
    Dim i As Integer

    If TypeName(Selection) <> "Range" Then Exit Sub
    Set r = Application.Intersect(ActiveSheet.UsedRange, Selection)
    If r Is Nothing Then
        MsgBox "データがありません。", vbExclamation, myTitle
        Exit Sub
    End If
    If MsgBox("このマクロは空白を含む表示形式を設定します。" & Chr$(10) & _
        "日付文字列として認識されないことがありますので、" & _
        "テキストファイルに保存する場合は、通常の表示形式を" & _
        "設定することをおすすめします。" & Chr$(10) & Chr$(10) & _
        "次に表示されるダイアログボックスで、基本となる表示形式を設定してください。" _
        , vbOKCancel Or vbExclamation, myTitle) <> vbOK Then Exit Sub

    If Application.Intersect(r, ActiveCell) Is Nothing Then
        r.Select
    Else
        Set obj = ActiveCell
        r.Select
        obj.Activate
    End If

    v = ActiveCell.Value
    s = ActiveCell.NumberFormatLocal

    stat = ActiveWindow.WindowState
    Set obj = Workbooks.Add(xlWorksheet)
    obj.Activate
    ActiveWindow.WindowState = xlMaximum
    ActiveWindow.Caption = myTitle

    With ActiveSheet.Cells(1, 1)
        If VarType(v) = vbDate Then
            .Value = v
            .NumberFormatLocal = s
        Else
            .Value = Date
        End If
        .Columns.AutoFit
    End With

    If Application.Dialogs(xlDialogFormatNumber).Show Then
        s = obj.Worksheets(1).Cells(1, 1).NumberFormatLocal
        obj.Close False
        r.Worksheet.Parent.Activate
        ActiveWindow.WindowState = stat
    Else
        obj.Close False
        r.Worksheet.Parent.Activate
        ActiveWindow.WindowState = stat
        Exit Sub
    End If

    v = MsgBox("年数字の位置合わせを行いますか?", _
        vbYesNoCancel Or vbExclamation, myTitle)
    If v = vbCancel Then Exit Sub

    SetFormatTable s, a(), (v = vbYes)

    If MsgBox("以下の表示形式を設定します。" & Chr$(10) & Chr$(10) _
        & "1桁: " & a(7) & " (" & Application.Text(#7/7/2003#, a(7)) & ")" _
        & Chr$(10) _
        & "2桁: " & a(0) & " (" & Application.Text(#11/11/2003#, a(0)) & ")" _
        & Chr$(10), vbOKCancel Or vbExclamation, myTitle) <> vbOK Then Exit Sub

    For Each r In Selection.Cells
        v = r.Value
        Select Case VarType(v)
            Case vbDate, vbDouble, vbCurrency
                If Day(v) < 10 Then i = 1 Else i = 0
                If Month(v) < 10 Then i = i + 2
                If CInt(Format$(v, "ee")) < 10 Then i = i + 4
                r.NumberFormatLocal = a(i)
        End Select
    Next
End Sub


Sub SetFormatTable(s As String, a() As String, b As Boolean)
    Const mySpace = "_0"
    Dim i As Integer, j As Integer
    Dim ch As String
    Dim s2 As String, s3 As String
    Dim s4 As String, s5 As String, s6 As String
    Dim flag As Boolean
    Dim iPos As Integer

    If b Then s6 = "dme" Else s6 = "dm"

    i = 1
    flag = False
    Do While i <= Len(s)
        ch = Mid$(s, i, 1)
        If ch = """" Then
            flag = Not flag
            s2 = s2 & ch
            s3 = s3 & Space(1)
            i = i + 1
        ElseIf flag Then
            s2 = s2 & ch
            s3 = s3 & Space(1)
            i = i + 1
        Else
            Select Case ch
                Case "!"
                    s2 = s2 & Mid$(s, i, 2)
                    s3 = s3 & Space(2)
                    i = i + 2
                Case "["
                    iPos = InStr(i + 1, s, "]", 0)
                    If iPos > 0 Then
                        s2 = s2 & Mid$(s, i, iPos - i + 1)
                        s3 = s3 & Space(iPos - i + 1)
                        i = iPos + 1
                    Else
                        s2 = s2 & Mid$(s, i)
                        s3 = s3 & Space(Len(s) - i + 1)
                        i = Len(s) + 1
                    End If
                Case Else
                    If InStr(1, s6, ch, 1) > 0 Then
                        j = i + 1
                        Do While StrComp(ch, Mid$(s, j, 1)) = 0
                            j = j + 1
                        Loop
                        If j <= i + 2 Then
                            If (i > 2) And (j = i + 1) Then
                                If Mid$(s, i - 2, 2) = mySpace Then
                                    s2 = Left$(s2, Len(s2) - 2)
                                    s3 = Left$(s3, Len(s3) - 2)
                                End If
                            End If
                            s2 = s2 & ch & ch
                            s3 = s3 & ch & ch
                        Else
                            s2 = s2 & Mid$(s, i, j - i)
                            s3 = s3 & Space(j - i)
                        End If
                        i = j
                    Else
                        s2 = s2 & ch
                        s3 = s3 & Space(1)
                        i = i + 1
                    End If
            End Select
        End If
    Loop

    a(0) = s2
    For i = 1 To 7
        s4 = ""
        s5 = ""
        For j = 0 To 2
            If (i And (2 ^ j)) <> 0 Then s4 = s4 & Mid$("dme", j + 1, 1)
        Next
        j = 1
        Do While j <= Len(s3)
            If InStr(1, s4, Mid$(s3, j, 1), 1) = 0 Then
                s5 = s5 & Mid$(s2, j, 1)
                j = j + 1
            Else
                s5 = s5 & mySpace & Mid$(s3, j, 1)
                j = j + 2
            End If
        Loop
        a(i) = s5
    Next
End Sub