■

誕生日処理変更。
最終行取得を連番に修正。
修正日処理変更。

｢通販管理｣→「顧客名簿」

Sub MacroTuuhanTenki()
    Application.ScreenUpdating = False
    Dim i As Integer
    Dim j As Integer
    Dim kokyaku_Last As Long            '顧客名簿の最終行
    Dim tuuhan_Last As Long             '通販管理の最終行
    Dim KOmidasi_name(11) As String     '顧客名簿の見出の文字列
    Dim Tmidasi_name(9) As String       '通販管理の見出の文字列
    Dim KOmidasi_column(11) As Integer  '顧客名簿の見出の位置
    Dim Tmidasi_column(9) As Integer    '通販管理の見出の位置
    Dim r As Range
    Dim fSelect As Boolean              '名前が選択されているか
    Dim f As Boolean                    '登録済み顧客か
    Dim f2 As Boolean
    Dim myCount1 As Long                '登録済み顧客の転記数
    Dim myCount2 As Long                '新規登録顧客の転記数
    Dim f3 As Boolean
    
    '顧客名簿の見出の文字列。シートを変更する場合はこちらも変更
    KOmidasi_name(0) = "会員番号"
    KOmidasi_name(1) = "旧会員番号"
    KOmidasi_name(2) = "会員資格"
    KOmidasi_name(3) = "名前"
    KOmidasi_name(4) = "フリガナ"
    KOmidasi_name(5) = "郵便番号"
    KOmidasi_name(6) = "住所"
    KOmidasi_name(7) = "電話番号"
    KOmidasi_name(8) = "メール"
    KOmidasi_name(9) = "登録日"
    KOmidasi_name(10) = "修正日"
    KOmidasi_name(11) = "連番"
    
    '通販管理の見出の文字列。シートを変更する場合はこちらも変更
    Tmidasi_name(0) = "会員番号"
    Tmidasi_name(1) = "旧会員番号"
    Tmidasi_name(2) = "会員資格"
    Tmidasi_name(3) = "名前"
    Tmidasi_name(4) = "フリガナ"
    Tmidasi_name(5) = "郵便番号"
    Tmidasi_name(6) = "住所"
    Tmidasi_name(7) = "電話番号"
    Tmidasi_name(8) = "メール"
    Tmidasi_name(9) = "登録日"
   
    Const kokyaku_Midasi As Long = 1    '顧客名簿の見出の行
    Const tuuhan_Midasi As Long = 1     '通販管理の見出の行
    
    For j = 0 To 11
        For i = 1 To 256
            If Worksheets("顧客名簿").Cells(kokyaku_Midasi, i).Value = KOmidasi_name(j) Then
                KOmidasi_column(j) = i
                Exit For
            End If
        Next i
    Next j
    For i = 0 To 11
        If KOmidasi_column(i) = 0 Then
            MsgBox "顧客名簿の見出を確認してください"
            Exit Sub
        End If
    Next i
    For j = 0 To 9
        For i = 1 To 256
            If Worksheets("通販管理").Cells(tuuhan_Midasi, i).Value = Tmidasi_name(j) Then
                Tmidasi_column(j) = i
                Exit For
            End If
        Next i
    Next j
    For i = 0 To 9
        If Tmidasi_column(i) = 0 Then
            MsgBox "通販管理の見出を確認してください"
            Exit Sub
        End If
    Next i
    
    kokyaku_Last = Worksheets("顧客名簿").Cells(Rows.Count, KOmidasi_column(11)).End(xlUp).Row
    tuuhan_Last = Worksheets("通販管理").Cells(Rows.Count, Selection.Column).End(xlUp).Row
    
    If MsgBox("[はい]→選択したすべてのデータは未登録データのみを追加する。" & vbCrLf & _
        "[いいえ]→選択したすべてのデータは上書きする。（上書きする場合は十分注意してください。）", vbQuestion + vbYesNo, _
        "既存顧客に未登録データのみを追加しますか？") = vbYes Then
        f3 = True
    End If
    
    '転記部分
    With Worksheets("顧客名簿")
        For Each r In Selection
            If r.Column = Tmidasi_column(3) And r.Row > tuuhan_Midasi And r.Row <= tuuhan_Last Then
                fSelect = True
                f = False
                For i = kokyaku_Midasi + 1 To kokyaku_Last
                    If Replace(.Cells(i, KOmidasi_column(3)).Value, " ", "", , , 1) = _
                        Replace(Worksheets("通販管理").Cells(r.Row, Tmidasi_column(3)).Value, " ", "", , , 1) And _
                        .Cells(i, KOmidasi_column(8)).Value = Worksheets("通販管理").Cells(r.Row, Tmidasi_column(8)).Value Then
                        f2 = False
                        f = True
                        If f3 Then
                            For j = 0 To 9
                                If .Cells(i, KOmidasi_column(j)).Value = "" And _
                                    Worksheets("通販管理").Cells(r.Row, Tmidasi_column(j)).Value <> "" Then
                                    Select Case j
                                        Case 3
                                        Case 4
                                            .Cells(i, KOmidasi_column(4)).Value = _
                                                Replace(StrConv(Worksheets("通販管理").Cells(r.Row, Tmidasi_column(4)), vbWide), "　", "", , , 1)
                                            f2 = True
                                        Case 5
                                            .Cells(i, KOmidasi_column(5)).Value = _
                                                Replace(Replace(Worksheets("通販管理").Cells(r.Row, Tmidasi_column(5)), "-", "", , , 1), "ー", "", , , 1)
                                            f2 = True
                                        Case 8
                                        Case Else
                                            .Cells(i, KOmidasi_column(j)).Value = Worksheets("通販管理").Cells(r.Row, Tmidasi_column(j)).Value
                                            f2 = True
                                    End Select
                                End If
                            Next j
                        Else
                            For j = 0 To 9
                                If Worksheets("通販管理").Cells(r.Row, Tmidasi_column(j)).Value <> "" Then
                                    Select Case j
                                        Case 3
                                        Case 4
                                            .Cells(i, KOmidasi_column(4)).Value = _
                                                Replace(StrConv(Worksheets("通販管理").Cells(r.Row, Tmidasi_column(4)), vbWide), "　", "", , , 1)
                                            f2 = True
                                        Case 5
                                            .Cells(i, KOmidasi_column(5)).Value = _
                                                Replace(Replace(Worksheets("通販管理").Cells(r.Row, Tmidasi_column(5)), "-", "", , , 1), "ー", "", , , 1)
                                            f2 = True
                                        Case 8
                                        Case Else
                                            .Cells(i, KOmidasi_column(j)).Value = Worksheets("通販管理").Cells(r.Row, Tmidasi_column(j)).Value
                                            f2 = True
                                    End Select
                                End If
                            Next j
                        End If
                        .Cells(i, KOmidasi_column(3)).Value = _
                            Replace(Worksheets("通販管理").Cells(r.Row, Tmidasi_column(3)).Value, " ", "　", , , vbBinaryCompare)
                        If f2 Then
                            myCount1 = myCount1 + 1
                            .Cells(i, KOmidasi_column(10)).Value = Date
                        End If
                    End If
                Next i
                '新規登録の場合
                If f = False Then
                    kokyaku_Last = kokyaku_Last + 1
                    For j = 0 To 9
                        .Cells(kokyaku_Last, KOmidasi_column(j)).Value = _
                            Worksheets("通販管理").Cells(r.Row, Tmidasi_column(j)).Value
                    Next j
                    .Cells(kokyaku_Last, KOmidasi_column(3)).Value = _
                        Replace(Worksheets("通販管理").Cells(r.Row, Tmidasi_column(3)).Value, " ", "　", , , vbBinaryCompare)
                    .Cells(kokyaku_Last, KOmidasi_column(4)).Value = _
                        Replace(StrConv(Worksheets("通販管理").Cells(r.Row, Tmidasi_column(4)), vbWide), "　", "", , , 1)
                    .Cells(kokyaku_Last, KOmidasi_column(5)).Value = _
                        Replace(Replace(Worksheets("通販管理").Cells(r.Row, Tmidasi_column(5)), "-", "", , , 1), "ー", "", , , 1)
                    .Cells(kokyaku_Last, KOmidasi_column(10)).Value = Date
                    .Cells(kokyaku_Last, KOmidasi_column(11)).Value = .Cells(kokyaku_Last - 1, KOmidasi_column(11)) + 1
                    myCount2 = myCount2 + 1
                End If
            End If
        Next r
    End With
    
    If fSelect Then
        If myCount1 = 0 And myCount2 = 0 Then
            MsgBox "追加・修正するデータはありませんでした"
        Else
            MsgBox "既存顧客を " & myCount1 & " 件修正しました" & vbCrLf & "新規顧客を " & myCount2 & " 件追加しました"
        End If
    Else
        MsgBox "操作が誤っています。通販管理で名前を選択してから実行してください"
    End If
    
    Application.ScreenUpdating = True
End Sub

｢会員管理｣→「顧客名簿」

Sub MacroKaiinTenki()
    Application.ScreenUpdating = False
    Dim i As Integer
    Dim j As Integer
    Dim kokyaku_Last As Long            '顧客名簿の最終行
    Dim kaiin_Last As Long              '会員管理の最終行
    Dim KOmidasi_name(13) As String     '顧客名簿の見出の文字列
    Dim KAmidasi_name(9) As String      '会員管理の見出の文字列
    Dim KOmidasi_column(13) As Integer  '顧客名簿の見出の位置
    Dim KAmidasi_column(9) As Integer   '会員管理の見出の位置
    Dim r As Range
    Dim fSelect As Boolean              '名前が選択されているか
    Dim f As Boolean                    '登録済み顧客か
    Dim f2 As Boolean
    Dim myCount1 As Long                '登録済み顧客の転記数
    Dim myCount2 As Long                '新規登録顧客の転記数
    Dim f3 As Boolean
    Dim str As String
    
    '顧客名簿の見出の文字列。シートを変更する場合はこちらも変更
    KOmidasi_name(0) = "名前"
    KOmidasi_name(1) = "フリガナ"
    KOmidasi_name(2) = "郵便番号"
    KOmidasi_name(3) = "住所"
    KOmidasi_name(4) = "電話番号"
    KOmidasi_name(5) = "メール"
    KOmidasi_name(6) = "携帯メール"
    KOmidasi_name(7) = "登録日"
    KOmidasi_name(8) = "会員期限"
    KOmidasi_name(9) = "連番"
    KOmidasi_name(10) = "誕生年"
    KOmidasi_name(11) = "誕生月"
    KOmidasi_name(12) = "誕生日"
    KOmidasi_name(13) = "修正日"
    
    '会員管理の見出の文字列。シートを変更する場合はこちらも変更
    KAmidasi_name(0) = "お名前"
    KAmidasi_name(1) = "フリガナ"
    KAmidasi_name(2) = "郵便番号"
    KAmidasi_name(3) = "住所"
    KAmidasi_name(4) = "電話番号"
    KAmidasi_name(5) = "メール"
    KAmidasi_name(6) = "携帯メール"
    KAmidasi_name(7) = "登録日"
    KAmidasi_name(8) = "情報１"
    KAmidasi_name(9) = "生年月日"
   
    Const kokyaku_Midasi As Long = 1    '顧客名簿の見出の行
    Const kaiin_Midasi As Long = 1      '会員管理の見出の行
    
    For j = 0 To 13
        For i = 1 To 256
            If Worksheets("顧客名簿").Cells(kokyaku_Midasi, i).Value = KOmidasi_name(j) Then
                KOmidasi_column(j) = i
                Exit For
            End If
        Next i
    Next j
    For i = 0 To 13
        If KOmidasi_column(i) = 0 Then
            MsgBox "顧客名簿の見出を確認してください"
            Exit Sub
        End If
    Next i
    For j = 0 To 9
        For i = 1 To 256
            If Worksheets("会員管理").Cells(kaiin_Midasi, i).Value = KAmidasi_name(j) Then
                KAmidasi_column(j) = i
                Exit For
            End If
        Next i
    Next j
    For i = 0 To 9
        If KAmidasi_column(i) = 0 Then
            MsgBox "会員管理の見出を確認してください"
            Exit Sub
        End If
    Next i
    
    kokyaku_Last = Worksheets("顧客名簿").Cells(Rows.Count, KOmidasi_column(9)).End(xlUp).Row
    kaiin_Last = Worksheets("会員管理").Cells(Rows.Count, Selection.Column).End(xlUp).Row
   
    If MsgBox("[はい]→選択したすべてのデータは未登録データのみを追加する。" & vbCrLf & _
        "[いいえ]→選択したすべてのデータは上書きする。（上書きする場合は十分注意してください。）", vbQuestion + vbYesNo, _
        "既存顧客に未登録データのみを追加しますか？") = vbYes Then
        f3 = True
    End If
    
    '転記部分
    With Worksheets("顧客名簿")
        For Each r In Selection
            If r.Column = KAmidasi_column(0) And r.Row > kaiin_Midasi And r.Row <= kaiin_Last Then
                fSelect = True
                f = False
                For i = kokyaku_Midasi + 1 To kokyaku_Last
                    If Replace(.Cells(i, KOmidasi_column(0)).Value, " ", "", , , 1) = _
                        Replace(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(0)).Value, " ", "", , , 1) And _
                        .Cells(i, KOmidasi_column(5)).Value = Worksheets("会員管理").Cells(r.Row, KAmidasi_column(5)).Value Then
                        f2 = False
                        f = True
                        If f3 Then
                            For j = 1 To 8
                                If .Cells(i, KOmidasi_column(j)).Value = "" And _
                                    Worksheets("会員管理").Cells(r.Row, KAmidasi_column(j)).Value <> "" Then
                                    Select Case j
                                        Case 1
                                            .Cells(i, KOmidasi_column(1)).Value = _
                                                Replace(StrConv(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(1)), vbWide), "　", "", , , 1)
                                            f2 = True
                                        Case 2
                                            .Cells(i, KOmidasi_column(2)).Value = _
                                                Replace(Replace(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(2)), "-", "", , , 1), "ー", "", , , 1)
                                            f2 = True
                                        Case 5
                                        Case Else
                                            .Cells(i, KOmidasi_column(j)).Value = Worksheets("会員管理").Cells(r.Row, KAmidasi_column(j)).Value
                                            f2 = True
                                    End Select
                                End If
                            Next j
                            str = Worksheets("会員管理").Cells(r.Row, KAmidasi_column(9)).Value
                            If .Cells(i, KOmidasi_column(10)).Value = "" Then
                                If nen(str) <> "" Then
                                    .Cells(i, KOmidasi_column(10)).Value = nen(str)
                                    f2 = True
                                End If
                            End If
                            If .Cells(i, KOmidasi_column(11)).Value = "" Then
                                If tuki(str) <> "" Then
                                    .Cells(i, KOmidasi_column(11)).Value = tuki(str)
                                    f2 = True
                                End If
                            End If
                            If .Cells(i, KOmidasi_column(12)).Value = "" Then
                                If niti(str) <> "" Then
                                    .Cells(i, KOmidasi_column(12)).Value = niti(str)
                                    f2 = True
                                End If
                            End If
                        Else
                            For j = 1 To 8
                                If Worksheets("会員管理").Cells(r.Row, KAmidasi_column(j)).Value <> "" Then
                                    Select Case j
                                        Case 1
                                            .Cells(i, KOmidasi_column(1)).Value = _
                                                Replace(StrConv(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(1)), vbWide), "　", "", , , 1)
                                            f2 = True
                                        Case 2
                                            .Cells(i, KOmidasi_column(2)).Value = _
                                                Replace(Replace(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(2)), "-", "", , , 1), "ー", "", , , 1)
                                            f2 = True
                                        Case 5
                                        Case Else
                                            .Cells(i, KOmidasi_column(j)).Value = Worksheets("会員管理").Cells(r.Row, KAmidasi_column(j)).Value
                                            f2 = True
                                    End Select
                                End If
                            Next j
                            str = Worksheets("会員管理").Cells(r.Row, KAmidasi_column(9)).Value
                            If nen(str) <> "" Then
                                .Cells(i, KOmidasi_column(10)).Value = nen(str)
                                f2 = True
                            End If
                            If tuki(str) <> "" Then
                                .Cells(i, KOmidasi_column(11)).Value = tuki(str)
                                f2 = True
                            End If
                            If niti(str) <> "" Then
                                .Cells(i, KOmidasi_column(12)).Value = niti(str)
                                f2 = True
                            End If
                        End If
                        .Cells(i, KOmidasi_column(0)).Value = _
                            Replace(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(0)).Value, " ", "　", , , vbBinaryCompare)
                        If f2 Then
                            myCount1 = myCount1 + 1
                            .Cells(i, KOmidasi_column(13)).Value = Date
                        End If
                    End If
                Next i
                '新規登録の場合
                If f = False Then
                    kokyaku_Last = kokyaku_Last + 1
                    For j = 0 To 8
                        .Cells(kokyaku_Last, KOmidasi_column(j)).Value = _
                            Worksheets("会員管理").Cells(r.Row, KAmidasi_column(j)).Value
                    Next j
                    .Cells(kokyaku_Last, KOmidasi_column(0)).Value = _
                        Replace(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(0)).Value, " ", "　", , , vbBinaryCompare)
                    .Cells(kokyaku_Last, KOmidasi_column(1)).Value = _
                        Replace(StrConv(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(1)), vbWide), "　", "", , , 1)
                    .Cells(kokyaku_Last, KOmidasi_column(2)).Value = _
                        Replace(Replace(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(2)), "-", "", , , 1), "ー", "", , , 1)
                    .Cells(kokyaku_Last, KOmidasi_column(13)).Value = Date
                    .Cells(kokyaku_Last, KOmidasi_column(9)).Value = .Cells(kokyaku_Last - 1, KOmidasi_column(9)) + 1
                    str = Worksheets("会員管理").Cells(r.Row, KAmidasi_column(9)).Value
                    .Cells(kokyaku_Last, KOmidasi_column(10)).Value = nen(str)
                    .Cells(kokyaku_Last, KOmidasi_column(11)).Value = tuki(str)
                    .Cells(kokyaku_Last, KOmidasi_column(12)).Value = niti(str)
                    myCount2 = myCount2 + 1
                End If
            End If
        Next r
    End With
    
    If fSelect Then
        If myCount1 = 0 And myCount2 = 0 Then
            MsgBox "追加・修正するデータはありませんでした"
        Else
            MsgBox "既存顧客を " & myCount1 & " 件修正しました" & vbCrLf & "新規顧客を " & myCount2 & " 件追加しました"
        End If
    Else
        MsgBox "操作が誤っています。会員管理で名前を選択してから実行してください"
    End If
    
    Application.ScreenUpdating = True
End Sub

Function nen(str As String) As String
    Dim i As Integer
    i = InStr(1, str, "/", vbTextCompare)
    If i > 0 Then
        If IsNumeric(Left(str, i - 1)) Then
            nen = Left(str, i - 1)
            Exit Function
        End If
    End If
    nen = ""
End Function

Function tuki(str As String) As String
    Dim i As Integer
    Dim j As Integer
    i = InStr(1, str, "/", vbTextCompare)
    j = InStr(i + 1, str, "/", vbTextCompare)
    If i > 0 And j > 0 Then
        If IsNumeric(Mid(str, i + 1, j - i - 1)) Then
            tuki = Mid(str, i + 1, j - i - 1)
            Exit Function
        End If
    End If
    tuki = ""
End Function

Function niti(str As String) As String
    Dim i As Integer
    Dim j As Integer
    i = InStr(1, str, "/", vbTextCompare)
    j = InStr(i + 1, str, "/", vbTextCompare)
    If i > 0 And j > 0 Then
        If IsNumeric(Mid(str, j + 1)) Then
            niti = Mid(str, j + 1)
            Exit Function
        End If
    End If
    niti = ""
End Function