■

1) ｢通販管理｣→「顧客管理」
顧客管理に転記元列を追加。

Sub MacroTuuhanTenki1()
    Application.ScreenUpdating = False
    
    '管理ブックのパスを環境に合わせてください
    Const myPath As String = "C:\管理"
    '顧客管理のブック名
    Const wbName As String = "顧客管理.xls"
    '顧客名簿のワークシート名
    Const wsName As String = "顧客名簿"
    
    Dim i As Integer
    Dim j As Integer
    Dim kokyaku_Last As Long            '顧客名簿の最終行
    Dim tuuhan_Last As Long             '通販管理の最終行
    Dim KOmidasi_name(12) As String     '顧客名簿の見出の文字列
    Dim Tmidasi_name(9) As String       '通販管理の見出の文字列
    Dim KOmidasi_column(12) 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
    Dim dstWS As Worksheet              '顧客名簿シート
    Dim tuuWS As Worksheet              '通販管理シート
        
    '顧客名簿の見出の文字列。シートを変更する場合はこちらも変更
    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) = "転記元"
    
    '通販管理の見出の文字列。シートを変更する場合はこちらも変更
    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     '通販管理の見出の行
    
    Set tuuWS = ActiveSheet
    
    '顧客管理を開く
    On Error GoTo err_Trp
    If bookCheck(myPath & "\" & wbName) Then
        Set dstWS = Workbooks(wbName).Worksheets(wsName)
    Else
        Set dstWS = Workbooks.Open(myPath & "\" & wbName).Worksheets(wsName)
    End If
    On Error GoTo 0
    
    For j = 0 To 12
        For i = 1 To 256
            If dstWS.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 12
        If KOmidasi_column(i) = 0 Then
            MsgBox "顧客名簿の見出を確認してください"
            Exit Sub
        End If
    Next i
    For j = 0 To 9
        For i = 1 To 256
            If tuuWS.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 = dstWS.Cells(Rows.count, KOmidasi_column(11)).End(xlUp).Row
    tuuhan_Last = tuuWS.Cells(Rows.count, Selection.Column).End(xlUp).Row
    
    If MsgBox("[はい]→選択したすべてのデータは未登録データのみを追加する。" & vbCrLf & _
        "[いいえ]→選択したすべてのデータは上書きする。（上書きする場合は十分注意してください。）", vbQuestion + vbYesNo, _
        "既存顧客に未登録データのみを追加しますか？") = vbYes Then
        f3 = True
    End If
    
    '転記部分
    With dstWS
        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(tuuWS.Cells(r.Row, Tmidasi_column(3)).Value, " ", "", , , 1) And _
                        .Cells(i, KOmidasi_column(8)).Value = tuuWS.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 _
                                    tuuWS.Cells(r.Row, Tmidasi_column(j)).Value <> "" Then
                                    Select Case j
                                        Case 3
                                        Case 4
                                            .Cells(i, KOmidasi_column(4)).Value = _
                                                Replace(StrConv(tuuWS.Cells(r.Row, Tmidasi_column(4)), vbWide), "　", "", , , 1)
                                            f2 = True
                                        Case 5
                                            .Cells(i, KOmidasi_column(5)).Value = _
                                                Replace(Replace(tuuWS.Cells(r.Row, Tmidasi_column(5)), "-", "", , , 1), "ー", "", , , 1)
                                            f2 = True
                                        Case 8
                                        Case Else
                                            .Cells(i, KOmidasi_column(j)).Value = tuuWS.Cells(r.Row, Tmidasi_column(j)).Value
                                            f2 = True
                                    End Select
                                End If
                            Next j
                            If .Cells(i, KOmidasi_column(12)).Value = "" Then
                                .Cells(i, KOmidasi_column(12)).Value = "通販"
                                f2 = True
                            End If
                        Else
                            For j = 0 To 9
                                If tuuWS.Cells(r.Row, Tmidasi_column(j)).Value <> "" Then
                                    Select Case j
                                        Case 3
                                        Case 4
                                            .Cells(i, KOmidasi_column(4)).Value = _
                                                Replace(StrConv(tuuWS.Cells(r.Row, Tmidasi_column(4)), vbWide), "　", "", , , 1)
                                            f2 = True
                                        Case 5
                                            .Cells(i, KOmidasi_column(5)).Value = _
                                                Replace(Replace(tuuWS.Cells(r.Row, Tmidasi_column(5)), "-", "", , , 1), "ー", "", , , 1)
                                            f2 = True
                                        Case 8
                                        Case Else
                                            .Cells(i, KOmidasi_column(j)).Value = tuuWS.Cells(r.Row, Tmidasi_column(j)).Value
                                            f2 = True
                                    End Select
                                End If
                            Next j
                            .Cells(i, KOmidasi_column(12)).Value = "通販"
                        End If
                        .Cells(i, KOmidasi_column(3)).Value = _
                            Replace(tuuWS.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 = _
                            tuuWS.Cells(r.Row, Tmidasi_column(j)).Value
                    Next j
                    .Cells(kokyaku_Last, KOmidasi_column(3)).Value = _
                        Replace(tuuWS.Cells(r.Row, Tmidasi_column(3)).Value, " ", "　", , , vbBinaryCompare)
                    .Cells(kokyaku_Last, KOmidasi_column(4)).Value = _
                        Replace(StrConv(tuuWS.Cells(r.Row, Tmidasi_column(4)), vbWide), "　", "", , , 1)
                    .Cells(kokyaku_Last, KOmidasi_column(5)).Value = _
                        Replace(Replace(tuuWS.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
                    .Cells(kokyaku_Last, KOmidasi_column(12)).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
    
    Application.ScreenUpdating = True
    Exit Sub
    
err_Trp:
    Select Case Err.Number
        Case 1004
            MsgBox "顧客管理をオープンできません。パスを確認してください。"
        Case 9
            MsgBox "顧客管理の正しいブック名とシート名を指定してください。"
        Case Else
            MsgBox "顧客管理をオープンすることができませんでした。"
    End Select
    Application.ScreenUpdating = True
End Sub

'ブックが開いているかをチェック
Function bookCheck(myPath As String) As Boolean
    Dim f As Boolean
    Dim myBook As Workbook
    For Each myBook In Workbooks
        If myBook.Path & "\" & myBook.Name = myPath Then
            f = True
            Exit For
        End If
    Next
    bookCheck = f
End Function

2)「通販管理」→「来店記録」

Sub MacroTuuhanTenki2()
    Application.ScreenUpdating = False
    
    '管理ブックのパスを環境に合わせてください
    Const myPath As String = "C:\管理"
    '顧客管理のブック名
    Const wbName As String = "顧客管理.xls"
    '来店記録のワークシート名
    Const wsName As String = "来店記録"
    
    Dim i As Integer
    Dim j As Integer
    Dim raiten_Last As Long             '来店記録の最終行
    Dim tuuhan_Last As Long             '通販管理の最終行
    Dim Rmidasi_name(13) As String      '来店記録の見出の文字列
    Dim Tmidasi_name(14) As String      '通販管理の見出の文字列
    Dim Rmidasi_column(13) As Integer   '来店記録の見出の位置
    Dim Tmidasi_column(14) As Integer   '通販管理の見出の位置
    Dim r As Range
    Dim err_Mes As String               'エラーメッセージ
    Dim strDate As String
    Dim myDate As Date
    Dim fSelect As Boolean              '名前が選択されているか
    Dim myCount As Long                 '転記数
    Dim fZumi As Boolean                '済の行を転記しようとしたか
    Dim dstWS As Worksheet              '来店記録シート
    Dim tuuWS As Worksheet              '通販管理シート
    
    '来店記録の見出の文字列。シートを変更する場合はこちらも変更
    Rmidasi_name(0) = "店舗"
    Rmidasi_name(1) = "会員番号"
    Rmidasi_name(2) = "旧会員番号"
    Rmidasi_name(3) = "会員資格"
    Rmidasi_name(4) = "名前"
    Rmidasi_name(5) = "フリガナ"
    Rmidasi_name(6) = "来店日"
    Rmidasi_name(7) = "売上"
    Rmidasi_name(8) = "ポイント"
    Rmidasi_name(9) = "バッグポイント"
    Rmidasi_name(10) = "累計P数"
    Rmidasi_name(11) = "コメント"
    Rmidasi_name(12) = "商品名"
    Rmidasi_name(13) = "商品番号"
    
    '通販管理の見出の文字列。シートを変更する場合はこちらも変更
    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) = "バッグポイント"
    Tmidasi_name(10) = "累計ポイント"
    Tmidasi_name(11) = "コメント"
    Tmidasi_name(12) = "商品名"
    Tmidasi_name(13) = "商品番号"
    Tmidasi_name(14) = "来店記録チェック"
       
    Const raiten_Midasi As Long = 1     '来店記録の見出の行
    Const tuuhan_Midasi As Long = 1     '通販管理の見出の行
    
    Set tuuWS = ActiveSheet
    
    '顧客管理を開く
    On Error GoTo err_Trp
    If bookCheck(myPath & "\" & wbName) Then
        Set dstWS = Workbooks(wbName).Worksheets(wsName)
    Else
        Set dstWS = Workbooks.Open(myPath & "\" & wbName).Worksheets(wsName)
    End If
    On Error GoTo 0
    
    For j = 0 To 13
        For i = 1 To 256
            If dstWS.Cells(raiten_Midasi, i).Value = Rmidasi_name(j) Then
                Rmidasi_column(j) = i
                Exit For
            End If
        Next i
    Next j
    For i = 0 To 13
        If Rmidasi_column(i) = 0 Then
            MsgBox "来店記録の見出を確認してください"
            Exit Sub
        End If
    Next i
    For j = 1 To 14
        For i = 1 To 256
            If tuuWS.Cells(tuuhan_Midasi, i).Value = Tmidasi_name(j) Then
                Tmidasi_column(j) = i
                Exit For
            End If
        Next i
    Next j
    For i = 1 To 14
        If Tmidasi_column(i) = 0 Then
            MsgBox "通販管理の見出を確認してください"
            Exit Sub
        End If
    Next i
    
    raiten_Last = dstWS.Cells(Rows.count, Rmidasi_column(0)).End(xlUp).Row
    tuuhan_Last = tuuWS.Cells(Rows.count, Selection.Column).End(xlUp).Row
    
    '在庫管理の日付のチェック
    With dstWS
        For i = raiten_Midasi + 1 To raiten_Last
            If IsDate(.Cells(i, Rmidasi_column(6))) Then
                If myDate > DateValue(.Cells(i, Rmidasi_column(6))) Then
                    MsgBox "来店記録の来店日が日付順になっていません"
                    Exit Sub
                Else
                    myDate = DateValue(.Cells(i, Rmidasi_column(6)))
                End If
            Else
                MsgBox "在庫管理の来店日に日付以外が入力されています"
                Exit Sub
            End If
        Next i
    End With
    
    '転記部分
    With tuuWS
        For Each r In Selection
            If r.Column = Tmidasi_column(4) And r.Row > tuuhan_Midasi And r.Row <= tuuhan_Last Then
                fSelect = True
                If .Cells(r.Row, Tmidasi_column(14)).Value <> "済" Then
                    strDate = .Cells(r.Row, Tmidasi_column(6)).Value
                    strDate = "20" & Left(strDate, 2) & "/" & Mid(strDate, 3, 2) & "/" & Mid(strDate, 5, 2)
                    If IsDate(strDate) Then
                        For i = raiten_Midasi + 1 To raiten_Last + 1
                            If DateValue(strDate) < dstWS.Cells(i, Rmidasi_column(6)).Value Or _
                                dstWS.Cells(i, Rmidasi_column(6)).Value = "" Then
                                dstWS.Rows(i).EntireRow.Insert
                                dstWS.Cells(i, Rmidasi_column(0)).Value = "通販"
                                For j = 1 To 13
                                    dstWS.Cells(i, Rmidasi_column(j)).Value = .Cells(r.Row, Tmidasi_column(j)).Value
                                Next j
                                dstWS.Cells(i, Rmidasi_column(6)).Value = DateValue(strDate)
                                .Cells(r.Row, Tmidasi_column(14)).Value = "済"
                                myCount = myCount + 1
                                raiten_Last = raiten_Last + 1
                                Exit For
                            End If
                        Next i
                    Else
                        err_Mes = err_Mes & r.Row & "行の日付が不正です" & vbCrLf
                    End If
                Else
                    fZumi = True
                End If
            End If
        Next r
    End With
    
    If fSelect Then
        MsgBox myCount & "件の転記を終了しました"
    Else
        MsgBox "通販管理シートで名前を選択してから実行してください"
    End If
    If err_Mes <> "" Then MsgBox err_Mes
    If fZumi Then MsgBox "転記済みのデータが含まれていました"
    
    Application.ScreenUpdating = True
    Exit Sub
    
err_Trp:
    Select Case Err.Number
        Case 1004
            MsgBox "顧客管理をオープンできません。パスを確認してください。"
        Case 9
            MsgBox "顧客管理の正しいブック名とシート名を指定してください。"
        Case Else
            MsgBox "顧客管理をオープンすることができませんでした。"
    End Select
    Application.ScreenUpdating = True

End Sub

'ブックが開いているかをチェック
Function bookCheck(myPath As String) As Boolean
    Dim f As Boolean
    Dim myBook As Workbook
    For Each myBook In Workbooks
        If myBook.Path & "\" & myBook.Name = myPath Then
            f = True
            Exit For
        End If
    Next
    bookCheck = f
End Function

3)「商品管理」から「来店記録」

商品管理の列の変更に対応。

Sub MacroSyouhinTenki()
    Application.ScreenUpdating = False
    
    '管理ブックのパスを環境に合わせてください
    Const myPath As String = "C:\管理"
    '商品管理のブック名
    Const wbName As String = "商品管理.xls"
    '商品管理のワークシート名
    Const wsName As String = "商品管理"
    
    Dim i As Integer
    Dim j As Long
    Dim k As Integer
    Dim l As Integer
    Dim sName As String
    Dim sNum As String
    Dim retu() As Integer
    Dim f As Boolean
    Dim rr As Integer
    Dim r As Range
    Dim sList As String
    Dim dstWS As Worksheet              '商品管理シート
    Dim raiWS As Worksheet              '来店記録シート
    Dim syouhinNum As Integer           '商品管理の商品番号列
    Dim syouhinName As Integer          '商品管理の商品名列
    Dim r1 As Range
    Dim r2 As Range
    
    Set raiWS = ActiveSheet
    
    '商品管理を開く
    On Error GoTo err_Trp
    If bookCheck(myPath & "\" & wbName) Then
        Set dstWS = Workbooks(wbName).Worksheets(wsName)
    Else
        Set dstWS = Workbooks.Open(myPath & "\" & wbName).Worksheets(wsName)
    End If
    On Error GoTo 0
    
    Set r1 = dstWS.Rows(1).Find(what:="商品番号", lookat:=xlWhole)
    If r1 Is Nothing Then
        MsgBox "商品管理に商品番号の列がありません。"
        Exit Sub
    End If
    syouhinNum = r1.Column
    
    Set r2 = dstWS.Rows(1).Find(what:="商品名", lookat:=xlWhole)
    If r1 Is Nothing Then
        MsgBox "商品管理に商品名の列がありません。"
        Exit Sub
    End If
    syouhinName = r2.Column
    
    With raiWS
        '列に挿入されたることを考えて商品番号が何列目かを調べます
        i = 1
        While .Cells(1, i).Value <> "商品番号"
            i = i + 1
        Wend
        
        ReDim retu(0) As Integer
        For Each r In Selection
            rr = r.Row
            f = False
            For l = 0 To UBound(retu)
                If retu(l) = rr Then
                    f = True
                    Exit For
                End If
            Next l
            If f = False Then
                sName = ""
                sNum = ""
                k = i
                While .Cells(rr, k).Value <> ""
                    j = 2
                    While dstWS.Cells(j, syouhinNum).Value <> .Cells(rr, k).Value And _
                        dstWS.Cells(j, syouhinNum).Value <> ""
                        j = j + 1
                    Wend
                    
                    sList = dstWS.Cells(j, syouhinName).Value
                    If sList = "" Then
                        sList = "存在しない商品番号"
                    End If
                    
                    If sName = "" Then
                        sName = sList
                    Else
                        sName = sName & "," & sList
                    End If
                    If sNum = "" Then
                        sNum = .Cells(rr, k).Value
                    Else
                        sNum = sNum & "," & .Cells(rr, k).Value
                    End If
                    .Cells(rr, k).Value = ""
                    k = k + 1
                Wend
                
                .Cells(rr, i - 1).Value = sName
                .Cells(rr, i).Value = sNum
                
                ReDim Preserve retu(UBound(retu) + 1) As Integer
                retu(UBound(retu)) = rr
            End If
        Next r
    End With
    
    Application.ScreenUpdating = True
    Exit Sub
    
err_Trp:
    Select Case Err.Number
        Case 1004
            MsgBox "商品管理をオープンできません。パスを確認してください。"
        Case 9
            MsgBox "商品管理の正しいブック名とシート名を指定してください。"
        Case Else
            MsgBox "商品管理をオープンすることができませんでした。"
    End Select
    Application.ScreenUpdating = True
End Sub

'ブックが開いているかをチェック
Function bookCheck(myPath As String) As Boolean
    Dim f As Boolean
    Dim myBook As Workbook
    For Each myBook In Workbooks
        If myBook.Path & "\" & myBook.Name = myPath Then
            f = True
            Exit For
        End If
    Next
    bookCheck = f
End Function