エクセルのマクロの質問です。通販の顧客管理をエクセルで行っています。注文があった時にファイル「顧客名簿」から注文者の名前とメールで検索し、顧客登録されていなければ「顧客名簿」に新規に登録するというマクロを作りたいと思います。

Question

icta

46

45もっと見る

2500pt

コンピュータ

エクセルのマクロの質問です。通販の顧客管理をエクセルで行っています。注文があった時にファイル「顧客名簿」から注文者の名前とメールで検索し、顧客登録されていなければ「顧客名簿」に新規に登録するというマクロを作りたいと思います。

また顧客登録されていても「顧客名簿」に未登録の記載されていないデータがあれば記入できるようにしたいと考えています。今はこれを手作業で行っており、まず名前を検索、同一人物か確かめてからコピー＆ペーストを繰り返すという作業で大変時間がかかります。またデータが「顧客名簿」入力されていない場合がよくありトラブルの元になっています。ここを何とか改善したいと思います。
マクロの知識が浅いため、解決方法そのものを教えていただければうれしいです。もしそのまま使える完全なコードややり方を回答していただいた回答者の方には500ポイントを差し上げます。よろしくお願いいたします。
※文字制限のため｢顧客管理｣のサンプルデータ、仕様の詳細はこの下にある｢この質問・回答へのコメント｣に記載いたします。

回答の条件

1人10回まで

登録：2008/05/18 19:14:17
終了：2008/05/20 23:58:10

※ 有料アンケート・ポイント付き質問機能は2023年2月28日に終了しました。

No.1

SALINGER34549692008/05/18 23:59:10

ありがとうございます。回答できるようになりました。

とりあえず半分　「通販管理」→「顧客名簿」　です。

Sub MacroTuuhanTenki()
    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                '新規登録顧客の転記数
    
    '顧客名簿の見出の文字列。シートを変更する場合はこちらも変更
    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(0)).End(xlUp).Row
    tuuhan_Last = Worksheets("通販管理").Cells(Rows.Count, Selection.Column).End(xlUp).Row
   
    '転記部分
    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
                        For j = 0 To 9
                            If .Cells(i, KOmidasi_column(j)).Value = "" And j <> 3 And j <> 8 Then
                                .Cells(i, KOmidasi_column(j)).Value = Worksheets("通販管理").Cells(r.Row, Tmidasi_column(j)).Value
                                f2 = True
                            End If
                        Next j
                        If f2 Then myCount1 = myCount1 + 1
                        f = True
                    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, " ", "", , , 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
End Sub

注）横に長い行ができてしまいました、プラウザの横幅が狭いと勝手にコードが右端で折り返されることがあるので、コピーするときは折り返されてるところは直してください。

> SALINGERさん

ご返送遅くなりまして申し訳ありません。

電話回線の工事でネットにつなげずにおりました。

マクロは完全に希望通りの動作を確認し、大変うれしく思います。

最初はマクロ一つで｢顧客管理｣も「会員管理」も実行できるかなと思ったのですが、2つの方が後から手を加える時、判りやすくていいですね。

エラートラップにまで気を使っていただきありがとうございました。

なるほどこれは絶対必要ですね。

すべてのマクロに取り込むようにしてみます。

エラーや操作ミスの回避、表記の統一など実際の運用において今回のマクロにできれば以下のような機能を追加したいと思います。

1)は当初の仕様の前提と異なってしまうのですが、この作業も意外に多いことに気がつきました。

後出しで心苦しいのですがお力添えいただければ幸いです。

これまで手作業でコピー＆ペーストを繰り返してきたのがマクロでショートカットを作るとワンクリック一発でできますね。

まるでマジックのようです。

「コピー＆ペースト」という言葉を教えることから始めなければならないスタッフの教育でもこれなら簡単に説明ができます。

本当に大助かりです。

1）ダイアログの表示

・マクロを実行すると▼次のダイアログを表示し「データの追加」だけでなく「上書き」も可能にする。

『既存顧客の場合、データを上書きせず未登録データのみ追加します(通常)。「OK」をクリックしてください。

データの上書きをする場合は「上書きする」をクリックしてください。上書きする場合は十分注意してください。

[OK][上書きする]』

・[OK]をクリックした時は現在の仕様どおり、「上書きする」をクリックした時は判定に使った"名前"と"メール"以外を上書きする。但し、「会員管理」、「通販管理」の空データは「顧客名簿」に空データの上書きをしない。データが存在するもののみを上書きする。

2)表記の統一※名前、フリガナ、郵便番号、

・名前

「顧客名簿」「通販管理」「顧客管理」の"名前"列は同一人物かどうか判定するために姓と名の間のスペースを取り除いて判定するが、「顧客名簿」に出力するときは姓と名の間のスペースは見易さの点から残す。ただし表記を統一するため半角スペースは全角スペースに変換しておく。

例：「判定」　山本　太郎、田中花子→→山本太郎、田中花子

　　「出力」　山本　太郎、田中花子→→山本　太郎、田中　花子

・フリガナ

携帯からの注文者は半角フリガナを使うことが多い。そのため半角フリガナは全角フリガナに変換。姓と名のスペースは名前と異なり全角、半角スペースを問わず取り除く。

例：ヤマモト　タロウ、ﾀﾅｶﾊﾅｺ→ヤマモトタロウ、タナカハナコ

・郵便番号

郵便番号のハイフンとそれに準ずるもの（ー,－,-）は取り除いて数字のみにする。

2008/05/19 18:16:05

No.2

SALINGER34549692008/05/19 01:16:20

最初の回答にデータに空白があると、修正していなくても１件修正となるエラーがありました。

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

Sub MacroTuuhanTenki()
    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                '新規登録顧客の転記数
    
    '顧客名簿の見出の文字列。シートを変更する場合はこちらも変更
    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(0)).End(xlUp).Row
    tuuhan_Last = Worksheets("通販管理").Cells(Rows.Count, Selection.Column).End(xlUp).Row
   
    '転記部分
    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
                        For j = 0 To 9
                            If .Cells(i, KOmidasi_column(j)).Value = "" And j <> 3 And j <> 8 And _
                                Worksheets("通販管理").Cells(r.Row, Tmidasi_column(j)).Value <> "" Then
                                .Cells(i, KOmidasi_column(j)).Value = Worksheets("通販管理").Cells(r.Row, Tmidasi_column(j)).Value
                                f2 = True
                            End If
                        Next j
                        If f2 Then myCount1 = myCount1 + 1
                        f = True
                    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, " ", "", , , 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
End Sub

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

Sub MacroKaiinTenki()
    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                '新規登録顧客の転記数
    
    '顧客名簿の見出の文字列。シートを変更する場合はこちらも変更
    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(0)).End(xlUp).Row
    kaiin_Last = Worksheets("会員管理").Cells(Rows.Count, Selection.Column).End(xlUp).Row
   
    '転記部分
    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
                        For j = 0 To 8
                            If .Cells(i, KOmidasi_column(j)).Value = "" And j <> 0 And j <> 5 And _
                                Worksheets("会員管理").Cells(r.Row, KAmidasi_column(j)).Value <> "" Then
                                .Cells(i, KOmidasi_column(j)).Value = Worksheets("会員管理").Cells(r.Row, KAmidasi_column(j)).Value
                                f2 = True
                            End If
                        Next j
                        If Worksheets("会員管理").Cells(r.Row, KAmidasi_column(9)).Value <> "" Then
                            If .Cells(i, KOmidasi_column(10)).Value = "" Then
                                .Cells(i, KOmidasi_column(10)).Value = Year(DateValue(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(9)).Value))
                                f2 = True
                            End If
                            If .Cells(i, KOmidasi_column(11)).Value = "" Then
                                .Cells(i, KOmidasi_column(11)).Value = Month(DateValue(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(9)).Value))
                                f2 = True
                            End If
                            If .Cells(i, KOmidasi_column(12)).Value = "" Then
                                .Cells(i, KOmidasi_column(12)).Value = Day(DateValue(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(9)).Value))
                                f2 = True
                            End If
                        End If
                        If f2 Then myCount1 = myCount1 + 1
                        f = True
                    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, " ", "", , , 1)
                    .Cells(kokyaku_Last, KOmidasi_column(13)).Value = Date
                    .Cells(kokyaku_Last, KOmidasi_column(9)).Value = .Cells(kokyaku_Last - 1, KOmidasi_column(9)) + 1
                    .Cells(kokyaku_Last, KOmidasi_column(10)).Value = Year(DateValue(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(9)).Value))
                    .Cells(kokyaku_Last, KOmidasi_column(11)).Value = Month(DateValue(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(9)).Value))
                    .Cells(kokyaku_Last, KOmidasi_column(12)).Value = Day(DateValue(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(9)).Value))
                    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
End Sub

No.3

SALINGER34549692008/05/19 23:42:13

はてなにアップするにはコードが長くなってきました。

メッセージボックスには上書きというボタンは無いので、ユーザーフォームで作ろうかとも思いましたが、

それは別の機会に作ってみればいいと思います。

それで、OK・上書きするの変わりにメッセージを変えてはい・いいえにしています。

不具合が見つかりましたら教えてください。修正します。

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

Sub MacroTuuhanTenki()
    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                '新規登録顧客の転記数
    
    '顧客名簿の見出の文字列。シートを変更する場合はこちらも変更
    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(0)).End(xlUp).Row
    tuuhan_Last = Worksheets("通販管理").Cells(Rows.Count, Selection.Column).End(xlUp).Row
   
    '転記部分
    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 MsgBox("未登録データのみを追加する場合(通常)→「はい」" & vbCrLf & _
                            "全てのデータを上書きをする場合　　　　　→「いいえ」" & vbCrLf & _
                            "（上書きする場合は十分注意してください。）", vbQuestion + vbYesNo, _
                            "既存顧客に未登録データのみを追加しますか？") = vbYes 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(kokyaku_Last, KOmidasi_column(4)).Value = _
                                                Replace(StrConv(Worksheets("通販管理").Cells(r.Row, Tmidasi_column(4)), vbWide), "　", "", , , 1)
                                            f2 = True
                                        Case 5
                                            .Cells(kokyaku_Last, 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(kokyaku_Last, KOmidasi_column(4)).Value = _
                                                Replace(StrConv(Worksheets("通販管理").Cells(r.Row, Tmidasi_column(4)), vbWide), "　", "", , , 1)
                                            f2 = True
                                        Case 5
                                            .Cells(kokyaku_Last, 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
                    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
End Sub

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

Sub MacroKaiinTenki()
    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                '新規登録顧客の転記数
    
    '顧客名簿の見出の文字列。シートを変更する場合はこちらも変更
    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(0)).End(xlUp).Row
    kaiin_Last = Worksheets("会員管理").Cells(Rows.Count, Selection.Column).End(xlUp).Row
   
    '転記部分
    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 MsgBox("未登録データのみを追加する場合(通常)→「はい」" & vbCrLf & _
                            "全てのデータを上書きをする場合　　　　　→「いいえ」" & vbCrLf & _
                            "（上書きする場合は十分注意してください。）", vbQuestion + vbYesNo, _
                            "既存顧客に未登録データのみを追加しますか？") = vbYes 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(kokyaku_Last, KOmidasi_column(1)).Value = _
                                                Replace(StrConv(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(1)), vbWide), "　", "", , , 1)
                                            f2 = True
                                        Case 2
                                            .Cells(kokyaku_Last, KOmidasi_column(2)).Value = _
                                                Replace(Replace(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(2)), "-", "", , , 1), "ー", "", , ,

SALINGER · Accepted Answer · 2008-05-20T00:28:23+09:00

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

Sub MacroKaiinTenki()
    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                '新規登録顧客の転記数
    
    '顧客名簿の見出の文字列。シートを変更する場合はこちらも変更
    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(0)).End(xlUp).Row
    kaiin_Last = Worksheets("会員管理").Cells(Rows.Count, Selection.Column).End(xlUp).Row
   
    '転記部分
    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 MsgBox("未登録データのみを追加する場合(通常)→「はい」" & vbCrLf & _
                            "全てのデータを上書きをする場合　　　　　→「いいえ」" & vbCrLf & _
                            "（上書きする場合は十分注意してください。）", vbQuestion + vbYesNo, _
                            "既存顧客に未登録データのみを追加しますか？") = vbYes 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(kokyaku_Last, KOmidasi_column(1)).Value = _
                                                Replace(StrConv(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(1)), vbWide), "　", "", , , 1)
                                            f2 = True
                                        Case 2
                                            .Cells(kokyaku_Last, 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
                            If Worksheets("会員管理").Cells(r.Row, KAmidasi_column(9)).Value <> "" Then
                                If .Cells(i, KOmidasi_column(10)).Value = "" Then
                                    .Cells(i, KOmidasi_column(10)).Value = Year(DateValue(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(9)).Value))
                                    f2 = True
                                End If
                                If .Cells(i, KOmidasi_column(11)).Value = "" Then
                                    .Cells(i, KOmidasi_column(11)).Value = Month(DateValue(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(9)).Value))
                                    f2 = True
                                End If
                                If .Cells(i, KOmidasi_column(12)).Value = "" Then
                                    .Cells(i, KOmidasi_column(12)).Value = Day(DateValue(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(9)).Value))
                                    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(kokyaku_Last, KOmidasi_column(1)).Value = _
                                                Replace(StrConv(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(1)), vbWide), "　", "", , , 1)
                                            f2 = True
                                        Case 2
                                            .Cells(kokyaku_Last, 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
                            If Worksheets("会員管理").Cells(r.Row, KAmidasi_column(9)).Value <> "" Then
                                .Cells(i, KOmidasi_column(10)).Value = Year(DateValue(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(9)).Value))
                                .Cells(i, KOmidasi_column(11)).Value = Month(DateValue(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(9)).Value))
                                .Cells(i, KOmidasi_column(12)).Value = Day(DateValue(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(9)).Value))
                                f2 = True
                            End If
                        End If
                        .Cells(kokyaku_Last, KOmidasi_column(0)).Value = _
                            Replace(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(0)).Value, " ", "　", , , vbBinaryCompare)
                        If f2 Then myCount1 = myCount1 + 1
                    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
                    .Cells(kokyaku_Last, KOmidasi_column(10)).Value = Year(DateValue(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(9)).Value))
                    .Cells(kokyaku_Last, KOmidasi_column(11)).Value = Month(DateValue(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(9)).Value))
                    .Cells(kokyaku_Last, KOmidasi_column(12)).Value = Day(DateValue(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(9)).Value))
                    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
End Sub

SALINGER · Accepted Answer · 2008-05-20T00:28:23+09:00

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

Sub MacroKaiinTenki()
    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                '新規登録顧客の転記数
    
    '顧客名簿の見出の文字列。シートを変更する場合はこちらも変更
    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(0)).End(xlUp).Row
    kaiin_Last = Worksheets("会員管理").Cells(Rows.Count, Selection.Column).End(xlUp).Row
   
    '転記部分
    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 MsgBox("未登録データのみを追加する場合(通常)→「はい」" & vbCrLf & _
                            "全てのデータを上書きをする場合　　　　　→「いいえ」" & vbCrLf & _
                            "（上書きする場合は十分注意してください。）", vbQuestion + vbYesNo, _
                            "既存顧客に未登録データのみを追加しますか？") = vbYes 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(kokyaku_Last, KOmidasi_column(1)).Value = _
                                                Replace(StrConv(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(1)), vbWide), "　", "", , , 1)
                                            f2 = True
                                        Case 2
                                            .Cells(kokyaku_Last, 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
                            If Worksheets("会員管理").Cells(r.Row, KAmidasi_column(9)).Value <> "" Then
                                If .Cells(i, KOmidasi_column(10)).Value = "" Then
                                    .Cells(i, KOmidasi_column(10)).Value = Year(DateValue(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(9)).Value))
                                    f2 = True
                                End If
                                If .Cells(i, KOmidasi_column(11)).Value = "" Then
                                    .Cells(i, KOmidasi_column(11)).Value = Month(DateValue(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(9)).Value))
                                    f2 = True
                                End If
                                If .Cells(i, KOmidasi_column(12)).Value = "" Then
                                    .Cells(i, KOmidasi_column(12)).Value = Day(DateValue(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(9)).Value))
                                    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(kokyaku_Last, KOmidasi_column(1)).Value = _
                                                Replace(StrConv(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(1)), vbWide), "　", "", , , 1)
                                            f2 = True
                                        Case 2
                                            .Cells(kokyaku_Last, 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
                            If Worksheets("会員管理").Cells(r.Row, KAmidasi_column(9)).Value <> "" Then
                                .Cells(i, KOmidasi_column(10)).Value = Year(DateValue(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(9)).Value))
                                .Cells(i, KOmidasi_column(11)).Value = Month(DateValue(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(9)).Value))
                                .Cells(i, KOmidasi_column(12)).Value = Day(DateValue(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(9)).Value))
                                f2 = True
                            End If
                        End If
                        .Cells(kokyaku_Last, KOmidasi_column(0)).Value = _
                            Replace(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(0)).Value, " ", "　", , , vbBinaryCompare)
                        If f2 Then myCount1 = myCount1 + 1
                    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
                    .Cells(kokyaku_Last, KOmidasi_column(10)).Value = Year(DateValue(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(9)).Value))
                    .Cells(kokyaku_Last, KOmidasi_column(11)).Value = Month(DateValue(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(9)).Value))
                    .Cells(kokyaku_Last, KOmidasi_column(12)).Value = Day(DateValue(Worksheets("会員管理").Cells(r.Row, KAmidasi_column(9)).Value))
                    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
End Sub

ベストアンサー

SALINGER34549692008/05/20 00:28:23

その他の回答（3件）

SALINGER34549692008/05/18 23:59:10

SALINGER34549692008/05/19 01:16:20

SALINGER34549692008/05/19 23:42:13

SALINGER34549692008/05/20 00:28:23ここでベストアンサー

コメント（24件)

この質問への反応（ブックマークコメント）

トラックバック