Excelマクロ作ってみました

仕事で作ったExcelマクロをなくさないようにメモ。
とあるだぶった項目を、その項目のID同様っていう文字列に変換するやつ

Sub ダブリ項目をホニャ同様に変えるマクロ()
'
' Macro2 Macro
' マクロ記録日 : 2005/5/26  ユーザー名 : UnKnown
'
' Keyboard Shortcut: Ctrl+Shift+T
'
    Dim Ypos As Integer
    
	
    'Eの列Topに移動
    Ypos = 6
    Do While Ypos <= 1850
    
        ' 区分けがBで無ければスキップ
        Range("A" + Trim(Str(Ypos))).Select
        If ActiveCell.Text = "B" Then
        
            ' IDを取得
            Range("B" + Trim(Str(Ypos))).Select
            Dim sID As Variant
            sID = ActiveCell.Text
        
            ' 検索文字列を取得
            Range("F" + Trim(Str(Ypos))).Select
            
            '現在のセルの中身を読み込む
            Dim SelContents As Variant
            SelContent = ActiveCell.Text
            
            '検索文字列がNULLではない、"同様"が打ち込まれていない、かつ、処理済みではないなら　置換処理
            If SelContent <> "" And Range("AK" + Trim(ActiveCell.Row)).Text <> "レ" And InStr(Range("H" + Trim(ActiveCell.Row)).Text, "同様") = 0 Then
                                
                '現在位置を保存
                Dim BkSel As Variant
                bkAddress = ActiveCell.Address()
                
                '検索範囲を選択して検索
                With Range(Selection, "F1:F1850")
                    Set Result = .Find(What:=SelContent, After:=ActiveCell, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False, MatchByte:=False, SearchFormat:=False)
                    Result.Select
                    
                    '検索元に戻ってきたら抜ける
                    Do While (Not Result Is Nothing) And (bkAddress <> ActiveCell.Address())
                        'あったら置換
                        
                        Dim TmpAddress As Variant
                        TmpAddress = ActiveCell.Address()
                        
                       'IDがBのものだけ置換
                        If Range("A" + Trim(ActiveCell.Row)).Text = "B" Then
                            'ENGLISH(H)
                            Range("H" + Trim(ActiveCell.Row)).Select
                            ActiveCell.Font.Color = RGB(0, 0, 255)
                            ActiveCell = sID + "同様。"
                            'GERMAN(J)
                            Range("J" + Trim(ActiveCell.Row)).Select
                            ActiveCell.Font.Color = RGB(0, 0, 255)
                            ActiveCell = sID + "同様。"
                            'FRENCH(L)
                            Range("L" + Trim(ActiveCell.Row)).Select
                            ActiveCell.Font.Color = RGB(0, 0, 255)
                            ActiveCell = sID + "同様。"
                            'DUTCH(N)
                            Range("N" + Trim(ActiveCell.Row)).Select
                            ActiveCell.Font.Color = RGB(0, 0, 255)
                            ActiveCell = sID + "同様。"
                            'SPANISH(P)
                            Range("P" + Trim(ActiveCell.Row)).Select
                            ActiveCell.Font.Color = RGB(0, 0, 255)
                            ActiveCell = sID + "同様。"
                            'ITALIAN(R)
                            Range("R" + Trim(ActiveCell.Row)).Select
                            ActiveCell.Font.Color = RGB(0, 0, 255)
                            ActiveCell = sID + "同様。"
                            'PORTUGUESE(T)
                            Range("T" + Trim(ActiveCell.Row)).Select
                            ActiveCell.Font.Color = RGB(0, 0, 255)
                            ActiveCell = sID + "同様。"
                            'RUSSIAN(V)
                            Range("V" + Trim(ActiveCell.Row)).Select
                            ActiveCell.Font.Color = RGB(0, 0, 255)
                            ActiveCell = sID + "同様。"
                            'KOREAN(X)
                            Range("X" + Trim(ActiveCell.Row)).Select
                            ActiveCell.Font.Color = RGB(0, 0, 255)
                            ActiveCell = sID + "同様。"
                            'TRADITHONAL-CHINESE(Z)
                            Range("Z" + Trim(ActiveCell.Row)).Select
                            ActiveCell.Font.Color = RGB(0, 0, 255)
                            ActiveCell = sID + "同様。"
                            'SIMPLE-CHINESE(AB)
                            Range("AB" + Trim(ActiveCell.Row)).Select
                            ActiveCell.Font.Color = RGB(0, 0, 255)
                            ActiveCell = sID + "同様。"
                            'ARABIC(AD)
                            Range("AD" + Trim(ActiveCell.Row)).Select
                            ActiveCell.Font.Color = RGB(0, 0, 255)
                            ActiveCell.Font.Name = "ＭＳ ゴシック"
                            ActiveCell = sID + "同様。"
                            'PERSIAN(AF)
                            Range("AF" + Trim(ActiveCell.Row)).Select
                            ActiveCell.Font.Color = RGB(0, 0, 255)
                            ActiveCell.Font.Name = "ＭＳ ゴシック"
                            ActiveCell = sID + "同様。"
                            
                            Range("AK" + Trim(ActiveCell.Row)) = "レ"
                        End If
                        
                        '元の位置に戻る
                        Range(TmpAddress).Select
                        
                        '検索Next
                        Set Result = .FindNext(After:=ActiveCell)
                        Result.Select
                    Loop
                End With
    
            End If
        
        End If
    
        '列一個進む
        Ypos = Ypos + 1
    Loop
End Sub