Malicious Office (OLE) / .XLS — malware analysis report

Attribute VB_Name = "Module1"
Sub 書込パス設定()


Const myPassold = "r373"
Const myPass = "r374"


Application.ScreenUpdating = False '画面更新を停止
On Error GoTo line 'エラーの場合エラー処理へ飛ぶ
myfdr = ActiveWorkbook.Path 'BOOKのフォルダー名取得
fname = Dir(myfdr & "\*.xls") 'フォルダ内のExcelブックを検索
Do Until fname = Empty '全てを検索
If fname <> ActiveWorkbook.Name Then 'ブック名がこのブックの名前でなければ
Set wb = Workbooks.Open(myfdr & "\" & fname, WriteResPassword:=myPassold) 'そのブックを開き、wbとする。
Application.DisplayAlerts = False '警告停止
wb.SaveAs Filename:=fname, WriteResPassword:=myPass '書き込みパスワード設定
wb.Close '閉じる
Application.DisplayAlerts = True '警告停止解除
n = n + 1 'ブック数をカウント
End If
fname = Dir 'フォルダ内の次のExcelブックを検索
Loop '繰り返す
Application.ScreenUpdating = True '画面更新停止を解除
MsgBox n & "件のブックを処理しましました。", vbInformation, " （￣ー￣）v "
Exit Sub
line: 'エラー処理
Application.ScreenUpdating = True '安全策
Application.DisplayAlerts = True '安全策
MsgBox "予期せぬ事由により" & n + 1 & "件目で失敗し、中断しました。", vbCritical, " Σ（￣ロ￣lll) "

End Sub

Sub シートの保護_パス_ncj()
Attribute シートの保護_パス_ncj.VB_Description = "マクロ記録日 : 2006/12/11  ユーザー名 : T.TESHIMA\n全てのシートにパスワード ncj にて一括保護\n保護の設定の選択は統制に準ずる"
Attribute シートの保護_パス_ncj.VB_ProcData.VB_Invoke_Func = "e\n14"
'
' ProctectSheetPass_ncj Macro
' マクロ記録日 : 2006/12/11  ユーザー名 : T.TESHIMA
' 全てのシートに『ncj』というパスワードを設定してシートの保護をする例です。
' Keyboard Shortcut: Ctrl+q
'
Dim W As Worksheet

  For Each W In Worksheets
  
    W.Protect Password:="ncj", DrawingObjects:=False, Contents:=True, Scenarios:= _
        True, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowFiltering:=True
        
  Next W
  
End Sub

'全てのシートに設定された『ncj』のパスワードのシートの保護を解除する例です。

Sub シートの保護解除_パス_ncj()
Attribute シートの保護解除_パス_ncj.VB_Description = "マクロ記録日 : 2006/12/11  ユーザー名 : T.TESHIMA\n全てのシートにパスワード ncj にて一括保護解除\n"
Attribute シートの保護解除_パス_ncj.VB_ProcData.VB_Invoke_Func = "r\n14"

  Dim W As Worksheet

  For Each W In Worksheets
    W.Unprotect Password:="ncj"
  Next W

End Sub

'シート名の一覧を表示する例です。

Sub シート一覧()
Dim W As Worksheet, i As Integer
For Each W In Worksheets
  i = i + 1
  Range("A" & i).Value = W.Name
Next W
End Sub


'アクティブブックに『1234』のパスワードでブックの保護をする例です。

Sub ブックの保護()

  ActiveWorkbook.Protect Password:="1234"

End Sub

'アクティブブックに設定された『1234』のパスワードのブックの保護を解除する例です。

Sub ブックの保護解除()

  ActiveWorkbook.Unprotect Password:="1234"
  
End Sub

Sub シートの保護_パス_200912()
Attribute シートの保護_パス_200912.VB_ProcData.VB_Invoke_Func = " \n14"
'
' ProctectSheetPass_ncj Macro
' 全てのシートに『200912』というパスワードを設定してシートの保護をする例です。
'
Dim W As Worksheet

  For Each W In Worksheets
  
    W.Protect Password:="200912", DrawingObjects:=False, Contents:=True, Scenarios:= _
        True, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowFiltering:=True
  Next W
  
End Sub

'全てのシートに設定された『200912』のパスワードのシートの保護を解除する例です。

Sub シートの保護解除_パス_200912()
Attribute シートの保護解除_パス_200912.VB_ProcData.VB_Invoke_Func = " \n14"

  Dim W As Worksheet

  For Each W In Worksheets
    W.Unprotect Password:="200912"
  Next W

End Sub
Sub シートの保護_パス_201003()
Attribute シートの保護_パス_201003.VB_ProcData.VB_Invoke_Func = "q\n14"
'
' ProctectSheetPass_ncj Macro
' 全てのシートに『201003』というパスワードを設定してシートの保護をする例です。
'
Dim W As Worksheet

  For Each W In Worksheets
  
    W.Protect Password:="201003", DrawingObjects:=False, Contents:=True, Scenarios:= _
        True, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowFiltering:=True
  Next W
  
End Sub

'全てのシートに設定された『201003』のパスワードのシートの保護を解除する例です。

Sub シートの保護解除_パス_201003()
Attribute シートの保護解除_パス_201003.VB_ProcData.VB_Invoke_Func = "w\n14"

  Dim W As Worksheet

  For Each W In Worksheets
    W.Unprotect Password:="201003"
  Next W

End Sub








'作成：NCJ経理 豊島'
Sub 同階層ファイル名取得()

    パス = ActiveWorkbook.Path
    
'当ファイルと同フォルダに入っているファイルの名前を取出、A列貼付'
    
    ファイル名 = Dir(パス & "\*.*")           'ファイル名を取り出す
    貼付行 = 5 - 1                            '貼付行ポインタを初期化する'
    Do While ファイル名 <> ""                 '取り出したファイル名がヌルでなければ
        貼付行 = 貼付行 + 1                 '貼付行ポインタを上げる
        If 貼付行 <= 2000 Then                 '(ファイル数+1)*20以上にすること'
          Cells(貼付行, 1).Value = ファイル名 'セルにファイル名を記入する
        End If
        ファイル名 = Dir()                    '次のファイル名を取り出す
    Loop
 
    
End Sub


Attribute VB_Name = "ThisWorkbook"
Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet1"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet2"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet3"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet4"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet5"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet6"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet7"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet8"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet9"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet10"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Module2"
'作成：NCJ経理 豊島'
Sub 当ファイルと同フォルダに入っているファイルの名前を取出､A列貼付()

    パス = ActiveWorkbook.Path
    
'当ファイルと同フォルダに入っているファイルの名前を取出、A列貼付'
    
    ファイル名 = Dir(パス & "\*.*")           'ファイル名を取り出す
    貼付行 = 5 - 1                            '貼付行ポインタを初期化する'
    Do While ファイル名 <> ""                 '取り出したファイル名がヌルでなければ
        貼付行 = 貼付行 + 18                   '貼付行ポインタを上げる
        If 貼付行 <= 2000 Then                 '(ファイル数+1)*20以上にすること'
          Cells(貼付行, 1).Value = ファイル名 'セルにファイル名を記入する
        End If
        ファイル名 = Dir()                    '次のファイル名を取り出す
    Loop
     
          i = 5 '初期の場所'
          

Do

r14 = ActiveSheet.Cells(i, 1) '上記までで貼り付けたファイル名を開くために定義づけ'


Workbooks.Open Filename:=パス & "\個別ファイル\" & r14, ReadOnly:= _
        True 'A列のファイル名を開く'

'9行目をコピー'
Sheets("1.affiliates").Select
Range("A14:J31").Select
Selection.Copy

'アクティブファイルを切り替え'
Windows("R-14集計マクロ.xls").Activate

'貼付ける'
ActiveSheet.Cells(i, 2).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

'アクティブファイルを切り替え'
Windows(r14).Activate

'ファイルを閉じる'
Application.CutCopyMode = False
ActiveWorkbook.Saved = True
    ActiveWorkbook.Close

      

         i = i + 18
Loop

    
End Sub





Attribute VB_Name = "Module3"
Option Explicit
Dim シート名 As String
Sub 引継仕訳作成()
Attribute 引継仕訳作成.VB_Description = "マクロ記録日 : 2007/6/8  ユーザー名 : T.TESHIMA"
Attribute 引継仕訳作成.VB_ProcData.VB_Invoke_Func = " \n14"
'
' Macro2 Macro
' マクロ記録日 : 2007/6/8  ユーザー名 : T.TESHIMA
'
    Range("B1").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("D1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    シート名 = Range("d1")
    Sheets.Add
    ActiveSheet.Name = シート名
    
    Sheets("piv").Select
    Columns("H:S").Select
    Selection.Copy
    Sheets(シート名).Select
    ActiveSheet.Paste
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("piv").Select
    Range("B1").Select
End Sub

Attribute VB_Name = "FrmCompare"
Attribute VB_Base = "0{58EA5872-4B11-4DBB-942E-1021589EEC66}{20A8AB91-55C7-4DAB-8BCD-96CC19CDD59B}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False



Private Sub BtnAddSel_Click()
    'クリックされたら選択範囲をリストに追加
    ProcSelect SelA$, SelR%
    If SelR% = 0 Then
        '同じ範囲があったらリストには追加しない
        CmbSrc.AddItem SelA$ '選択範囲名を追加
        CmbTgt.AddItem SelA$ '選択範囲名を追加
        CmbStart.AddItem SelA$ '選択範囲名を追加
    End If
End Sub

Private Sub BtnNext_Click()
    ProcSelect SelA$, SelR%
    CmbStart.Text = SelA$
    G_NextFlg = True
    BTNOK_Click
End Sub

Private Sub BTNOK_Click()
    Dim Src$, Tgt$, SrcWB$, TgtWB$, SrcWS$, TgtWS$, StartWB$, StartWS$, ChkNG$
    Dim SrcR%, SrcL%, SrcU%, SrcD%, TgtR%, TgtL%, TgtU%, TgtD%
    Dim StartR%, StartL%, StartU%, StartD%, StL%, StU%
    Dim R%, L2R%, U2D%, i%, j%, SrcDat, TgtDat
    Dim SrcRow%, SrcCol%, TgtRow%, TgtCol%
    Dim OrgColType%, OrgCol, ColNo%, Chk%
    Dim OldstatusBar As Boolean

    Src$ = CmbSrc.Text

    GetRange Src$, SrcWB$, SrcWS$, SrcL%, SrcR%, SrcU%, SrcD%, R%, True
    If R% > 0 Then GoTo ENDEND

    Tgt$ = CmbTgt.Text
    GetRange Tgt$, TgtWB$, TgtWS$, TgtL%, TgtR%, TgtU%, TgtD%, R%, True
    If R% > 0 Then GoTo ENDEND

    StL% = 0
    StU% = 0
    Start$ = CmbStart.Text
    If Start$ <> "" Then
        GetRange Start$, StartWB$, StartWS$, StartL%, StartR%, StartU%, StartD%, R%, False
        If R% > 0 Then GoTo ENDEND

        '選択したセルがSrcかTgtかを見て開始位置をオフセットする
        '同一シート内ならSrc優先
        If (StartWB$ + StartWS$) = (SrcWB$ + SrcWS$) Then
            StL% = StartL - SrcL%
            StU% = StartU% - SrcU%
        ElseIf (StartWB$ + StartWS$) = (TgtWB$ + TgtWS$) Then
            StL% = StartL - TgtL%
            StU% = StartU% - TgtU%
        Else
            MsgBox "開始位置のシート指定が違います"
            GoTo ENDEND
        End If
    End If

    'セルの色指定がされているかどうかを確認
    If Not ChkStop.Value Then
        If ActiveCell.Interior.ColorIndex = xlColorIndexNone Then
        '色指定されていない場合
            OrgColType = -1
        Else
        '色指定されていたら色を取得
            OrgColType = 0
            OrgCol = ActiveCell.Interior.Color
        End If

        '塗りつぶし色を取得してセルの色を元に戻す｡
        If Application.Dialogs(xlDialogPatterns).Show Then
        '色が選択されたら
            'セルから色番号を取得し
            ColNo% = ActiveCell.Interior.ColorIndex
            '色を書き戻す
            If OrgColType Then
            '色指定されていない場合は色指定なしに
                ActiveCell.Interior.ColorIndex = xlColorIndexNone
            Else
            '色指定されていたら色を書き戻す
                ActiveCell.Interior.Color = OrgCol
            End If
        Else
            MsgBox "色を指定してください"
            GoTo ENDEND
        End If
    End If

    G_SrcTxt$ = Src$
    G_TgtTxt$ = Tgt$

    '比較ルーチン
    LblStatus.Caption = ""
    Application.ScreenUpdating = False '画面表示しない

    '二つのシートの行列のそれぞれの多い方を比較範囲とする
    Max SrcR% - SrcL%, TgtR% - TgtL%, L2R%
    Max SrcD% - SrcU%, TgtD% - TgtU%, U2D%

    If StL% < 0 Or StU% < 0 Or StL% > L2R% Or StU% > U2D% Then
        MsgBox "開始位置が比較範囲の外です"
        GoTo ENDEND
    End If

    ChkNG$ = "違いはありません　"

    If ChkDirLine.Value Then
    '横方向に比較
        If G_NextFlg Then StL% = StL% + 1
        For i% = StU% To U2D%  '行
            If i% Mod 5 = 0 Then
                LblStatus.Caption = "　　" + Str(i%) + " 行処理中"
            End If

            For j% = StL% To L2R%  '列
                GoSub CellComp
                R% = vbYes
                If Chk% > 0 And ChkStop.Value Then GoSub DispMsg
                If R% = vbNo Then Exit For
            Next j%
            If R% = vbNo Then Exit For
            StL% = 0
        Next i%
    Else
    '縦方向に比較
        If G_NextFlg Then StU% = StU% + 1
        For j% = StL% To L2R%  '列
            If j% Mod 5 = 0 Then
                LblStatus.Caption = "　　" + Str(j%) + " 列処理中"
            End If

            For i% = StU% To U2D%  '行
                GoSub CellComp
                R% = vbYes
                If Chk% > 0 And ChkStop.Value Then GoSub DispMsg
                If R% = vbNo Then Exit For
            Next i%
            If R% = vbNo Then Exit For
            StU% = 0
        Next j%
    End If

    '正常に抜けた時はI%、J%とも一つ大きい値となっているので補正する
    If i% > U2D% Then i% = U2D%
    If j% > L2R% Then j% = L2R%
    
    If R% <> vbNo Then
        LblStatus.Caption = "終了しました　" & ChkNG$
    Else
        LblStatus.Caption = "Sheet1:" & Workbooks(SrcWB$).Worksheets(SrcWS$).Cells(SrcU% + i%, SrcL% + j%).Address _
        & "   Sheet2:" & Workbooks(TgtWB$).Worksheets(TgtWS$).Cells(TgtU% + i%, TgtL% + j%).Address
    End If
    
    Application.ScreenUpdating = True '画面表示再開
    Workbooks(TgtWB$).Worksheets(TgtWS$).Activate
    Workbooks(TgtWB$).Worksheets(TgtWS$).Cells(TgtRow%, TgtCol%).Activate
    Workbooks(SrcWB$).Worksheets(SrcWS$).Activate
    Workbooks(SrcWB$).Worksheets(SrcWS$).Cells(SrcRow%, SrcCol).Activate
    GoTo ENDEND
    'ここでこのルーチンは終了

'以下、サブルーチン
CellComp:
'セルの比較
    Chk% = 0
    SrcRow% = SrcU% + i
    SrcCol% = SrcL% + j
    TgtRow% = TgtU% + i
    TgtCol% = TgtL% + j

    '値の比較
    If ChkValue Then
        SrcDat = Workbooks(SrcWB$).Worksheets(SrcWS$).Cells(SrcRow%, SrcCol).Value
        TgtDat = Workbooks(TgtWB$).Worksheets(TgtWS$).Cells(TgtRow%, TgtCol%).Value
        If SrcDat <> TgtDat Then Chk% = Chk% + 1
    End If

    '計算式の比較
    If ChkFomula Then
        SrcDat = Workbooks(SrcWB$).Worksheets(SrcWS$).Cells(SrcRow%, SrcCol%).Formula
        TgtDat = Workbooks(TgtWB$).Worksheets(TgtWS$).Cells(TgtRow%, TgtCol%).Formula
        If SrcDat <> TgtDat Then Chk% = Chk% + 2
    End If

    '色の比較
    If ChkColor Then
        SrcDat = Workbooks(SrcWB$).Worksheets(SrcWS$).Cells(SrcRow%, SrcCol%).Interior.ColorIndex
        TgtDat = Workbooks(TgtWB$).Worksheets(TgtWS$).Cells(TgtRow%, TgtCol%).Interior.ColorIndex
        If SrcDat <> TgtDat Then Chk% = Chk% + 4
    End If

    '配置の比較
    If ChkAlign Then
        SrcDat = Workbooks(SrcWB$).Worksheets(SrcWS$).Cells(SrcRow%, SrcCol%).HorizontalAlignment
        TgtDat = Workbooks(TgtWB$).Worksheets(TgtWS$).Cells(TgtRow%, TgtCol%).HorizontalAlignment
        If SrcDat <> TgtDat Then Chk% = Chk% + 8
        SrcDat = Workbooks(SrcWB$).Worksheets(SrcWS$).Cells(SrcRow%, SrcCol%).VerticalAlignment
        TgtDat = Workbooks(TgtWB$).Worksheets(TgtWS$).Cells(TgtRow%, TgtCol%).VerticalAlignment
        If SrcDat <> TgtDat Then Chk% = Chk% + 16
    End If

    'フォント名の比較
    If ChkName Then
        SrcDat = Workbooks(SrcWB$).Worksheets(SrcWS$).Cells(SrcRow%, SrcCol%).Font.Name
        TgtDat = Workbooks(TgtWB$).Worksheets(TgtWS$).Cells(TgtRow%, TgtCol%).Font.Name
        If SrcDat <> TgtDat Then Chk% = Chk% + 32
    End If

    'フォントサイズの比較
    If ChkSize Then
        SrcDat = Workbooks(SrcWB$).Worksheets(SrcWS$).Cells(SrcRow%, SrcCol%).Font.Size
        TgtDat = Workbooks(TgtWB$).Worksheets(TgtWS$).Cells(TgtRow%, TgtCol%).Font.Size
        If SrcDat <> TgtDat Then Chk% = Chk% + 64
    End If

    'フォントスタイルの比較
    If ChkStyle Then
        SrcDat = Workbooks(SrcWB$).Worksheets(SrcWS$).Cells(SrcRow%, SrcCol%).Font.FontStyle
        TgtDat = Workbooks(TgtWB$).Worksheets(TgtWS$).Cells(TgtRow%, TgtCol%).Font.FontStyle
        If SrcDat <> TgtDat Then Chk% = Chk% + 128
    End If

    '異なっていた場合の処理
    If Chk% > 0 Then
        ChkNG$ = "違いが見つかりました　"
        If ChkStop.Value Then
            Workbooks(TgtWB$).Worksheets(TgtWS$).Activate
            Workbooks(TgtWB$).Worksheets(TgtWS$).Cells(TgtU% + i, TgtL% + j).Activate
            Workbooks(SrcWB$).Worksheets(SrcWS$).Activate
            Workbooks(SrcWB$).Worksheets(SrcWS$).Cells(SrcU% + i, SrcL% + j).Activate
        Else
            Workbooks(TgtWB$).Worksheets(TgtWS$).Cells(TgtRow%, TgtCol%).Interior.ColorIndex = ColNo%
            Workbooks(SrcWB$).Worksheets(SrcWS$).Cells(SrcRow%, SrcCol%).Interior.ColorIndex = ColNo%
        End If
    End If
Return

DispMsg:
    R% = MsgBox("Sheet1:" & Workbooks(SrcWB$).Worksheets(SrcWS$).Cells(SrcU% + i%, SrcL% + j%).Address & vbCrLf & """" & SrcDat & """" & vbCrLf _
        & vbCrLf & "Sheet2:" & Workbooks(TgtWB$).Worksheets(TgtWS$).Cells(TgtU% + i%, TgtL% + j%).Address & vbCrLf & """" & TgtDat & """" _
        & vbCrLf & vbCrLf & "続けて検索しますか?", vbYesNo, ChkNG$)
Return

ENDEND:
    G_NextFlg = False
End Sub

Sub Max(A%, B%, C%)
    If A% > B% Then
        C% = A%
    Else
        C% = B%
    End If
End Sub

Private Sub BTNCANCEL_Click()
    Unload FrmCompare
'    End
End Sub

Sub GetRange(Range$, wb$, ws$, RangeL%, RangeR%, RangeU%, RangeD%, ErrFlg%, AutoRange As Boolean)
    Dim R%, Tmp$
    Dim LU$, RD$, OrgRange$, RangeA$

    If Range$ = "" Then
    'ワークシート指定なし
        wb$ = ""
        ws$ = ""
        RangeR% = 0
        RangeL% = 0
        RangeU% = 0
        RangeD% = 0
        MsgBox ("ワークシートが指定されていません")
        ErrFlg% = 1
    Else
        R% = InStr(Range$, "_Named_")
        If R% > 1 Then
            Range$ = Mid(Range$, 1, R% - 1)
        End If
    'ワークシート指定あり
        'セル1つ->Sheet1!$B$3
        '複数セル->Sheet1!$B$3:$C$6
        'スペース入り->'Sheet1 (2)'!$A$1
        '他ブック->[Book1.xls]Sheet1!$A$1
        '他ブック->'[Book1.xls]Sheet1'!$A$1

        Tmp$ = Range$
        'ブック&ワークシート名と範囲を分離
        R% = InStr(Tmp$, "!")
        ws$ = Mid$(Tmp$, 1, R - 1)
        RangeA$ = Mid$(Tmp$, R + 1)

        'ブック名抽出
        R% = InStr(ws$, "]")
        If R% > 1 Then
        '他のブック参照の場合
            wb$ = Mid(ws$, 2, R% - 2)
            ws$ = Mid(ws$, R% + 1)
        Else
            wb$ = ActiveWorkbook.Name
        End If

        'ワークシート名抽出
        If InStr(ws$, "'") = 1 Then
        ' "'"で囲まれていたらそれを取る
            ws$ = Mid(ws$, 2, Len(ws$) - 2)
        End If


        Tmp$ = RangeA
        R% = InStr(Tmp$, ":")
        If R% > 1 Then
        '範囲指定ならその範囲を取得
            '左上
            LU$ = Left(Tmp$, R% - 1)
            '右下
            RD$ = Mid(Tmp$, R + 1)

            RangeU% = Workbooks(wb$).Worksheets(ws$).Range(LU$).row
            RangeL% = Workbooks(wb$).Worksheets(ws$).Range(LU$).Column
            RangeD% = Workbooks(wb$).Worksheets(ws$).Range(RD$).row
            RangeR% = Workbooks(wb$).Worksheets(ws$).Range(RD$).Column
        Else
        '範囲指定されていない場合はアクティブセルからデータの入っているセル範囲を自動で取得
        'データがないときはそのセルのみ
            If AutoRange Then
                With Workbooks(wb$).Worksheets(ws$).UsedRange
                    RangeU% = Workbooks(wb$).Worksheets(ws$).Range(Tmp$).row
                    RangeL% = Workbooks(wb$).Worksheets(ws$).Range(Tmp$).Column
                    RangeD% = .row + .Rows.Count - 1
                    RangeR% = .Column + .Columns.Count - 1
                    If RangeU% > RangeD% Then RangeU% = RangeD%
                    If RangeL% > RangeR% Then RangeL% = RangeR%
                End With
            Else
                RangeU% = Workbooks(wb$).Worksheets(ws$).Range(Tmp$).row
                RangeL% = Workbooks(wb$).Worksheets(ws$).Range(Tmp$).Column
                RangeD% = Workbooks(wb$).Worksheets(ws$).Range(Tmp$).row
                RangeR% = Workbooks(wb$).Worksheets(ws$).Range(Tmp$).Column
            End If
        End If
    End If
End Sub


Attribute VB_Name = "Compare"
Option Explicit

Global G_SrcTxt$, G_TgtTxt$, G_NextFlg As Boolean

Public Sub ProcSelect(G_SelA$, G_SelR%)
    '選択範囲をコンボボックスに追加するための前加工
    Dim Pos%, Tmp$, i%
    G_SelA$ = ""
    G_SelR% = 1

    On Error GoTo ENDNED
    '範囲以外のものが選択されていた時の対策
    Tmp$ = ActiveSheet.Name
    If InStr(Tmp$, " ") > 1 Then
        'シート名にスペースがあったら"'"で括る
        Tmp$ = "'" & Tmp$ & "'"
    End If

    G_SelA$ = "[" & ActiveWorkbook.Name & "]" & Tmp$ & "!" & Selection.Address

    With FrmCompare
        G_SelR% = 0
        For i% = 0 To .CmbSrc.ListCount - 1
        '同じ範囲があるかどうかチェック
            Tmp$ = .CmbSrc.List(i%)
            Pos% = InStr(Tmp$, "_Named_")
            If Pos% > 1 Then
                Tmp$ = Mid(Tmp$, 1, Pos% - 1)
            End If

            If Tmp$ = G_SelA$ Then G_SelR% = G_SelR% + 1
        Next i%

    End With
ENDNED:
End Sub

Attribute VB_Name = "UserForm1"
Attribute VB_Base = "0{B4205094-2858-43CA-A051-A20ABA12ACF5}{085F73DB-358A-4186-9F41-613D72042B64}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False


Private Sub 英語RP_Click()

Application.Run "PERSONAL.XLS!RPoriginal更新作業e"

End Sub

Private Sub 日本語RP_Click()

Application.Run "PERSONAL.XLS!RPoriginal更新作業"

End Sub

Attribute VB_Name = "Module4"
Option Explicit

Sub auto_open()                     'ここで起動時に（念のためいったん削除してから）メニューを追加（作成）します
                                    '既にauto_open() を記述している場合は、以下の２行を追加します。
    Menu削除 1
    Menu追加 1
'
End Sub

Sub auto_close()                    'エクセル終了時にメニューを削除します
'
    Menu削除 1
'
End Sub

Sub Menu追加(num%)                  'ダミーの引数(num%)を付けているのは、「ツール」「マクロ」から指定できないようにするため

    Dim myBar As CommandBar
    Dim myCtrl As CommandBarControl
    
'    Application.CommandBars("Worksheet Menu Bar").Reset     20021020変更
    Menu削除 1                                              '20021020変更

    Set myBar = CommandBars("Worksheet Menu Bar")
    Set myCtrl = myBar.Controls.Add(Type:=msoControlPopup, Temporary:=True)
    With myCtrl
                                                                                    '最初にココで、メニューバーに追加するメニュー名を指定する。
        .Caption = "MyTools(&X)"                                    '(&英数字)はショートカットの指定（なくてもOK）
        .Visible = True
        .Controls.Add Type:=msoControlButton
        .Controls(1).Caption = "電卓の起動(&0)"                        '表示されるメニューの名前を指定
        .Controls(1).OnAction = "Dentaku"                            '起動するマクロを指定
        .Controls(1).FaceId = 283                                    'メニューの左に表示されるアイコンを指定（指定しなくてもOK）
        .Controls.Add Type:=msoControlButton
        .Controls(2).Caption = "ｳｨﾝﾄﾞｳの上下整列(&1)"                'メニュー名の後ろに(&英数字)と記述すると、ショートカットの指定になる（なくてもOK）
        .Controls(2).OnAction = "ウィンドウの上下整列"
        .Controls(2).FaceId = 298
        .Controls(2).BeginGroup = True                                'これを指定すると、メニューをセパレートする横棒が入る
        .Controls.Add Type:=msoControlButton
        .Controls(3).Caption = "ｱｸﾃｨﾌﾞｼｰﾄの複数画面表示(&2)"
        .Controls(3).OnAction = "同一Sheetの複数画面表示"
        .Controls(3).FaceId = 585
        .Controls.Add Type:=msoControlButton
        .Controls(4).Caption = "ｾﾙ縦位置中央揃え(&3)"
        .Controls(4).OnAction = "セル縦位置中央揃え"
        .Controls(4).FaceId = 2062
        .Controls(4).BeginGroup = True
        .Controls.Add Type:=msoControlButton
        .Controls(5).Caption = "ｾﾙ縦位置上詰め(&4)"
        .Controls(5).OnAction = "セル縦位置上詰め"
        .Controls(5).FaceId = 2061
        .Controls.Add Type:=msoControlButton
        .Controls(6).Caption = "列幅で折り返し(&5)"
        .Controls(6).OnAction = "列幅折り返し表示"
        .Controls(6).FaceId = 119
        .Controls.Add Type:=msoControlButton
        .Controls(7).Caption = "全ｼｰﾄをHOMEﾎﾟｼﾞｼｮﾝに(&6)"
        .Controls(7).OnAction = "To_Home"
        .Controls(7).FaceId = 1826
        .Controls(7).BeginGroup = True
        .Controls.Add Type:=msoControlButton
        .Controls(8).Caption = "入力後のｾﾙ移動方向の変更(&7)"
        .Controls(8).OnAction = "セル移動方向切替"
        .Controls(8).FaceId = 133
        .Controls.Add Type:=msoControlButton
        .Controls(9).Caption = "枠線の表示切替(&W)"
        .Controls(9).OnAction = "枠線表示切替え"
        .Controls(9).FaceId = 217
        .Controls.Add Type:=msoControlButton
        .Controls(10).Caption = "行列番号の表示切替(&G)"
        .Controls(10).OnAction = "行列番号表示切替"
        .Controls(10).FaceId = 800
        .Controls.Add Type:=msoControlButton
        .Controls(11).Caption = "A1形式R1C1形式の切替(&A)"
        .Controls(11).OnAction = "A1_R1C1"
        .Controls(11).FaceId = 503
        .Controls.Add Type:=msoControlButton
        .Controls(12).Caption = "最近使用したファイルの一覧に追加(&S)"
        .Controls(12).OnAction = "Add_RecentFiles"
        .Controls(12).FaceId = 462
        .Controls.Add Type:=msoControlButton
        .Controls(13).Caption = "フォント設定の一覧を表示する(&V)"
        .Controls(13).OnAction = "font_check"
        .Controls(13).FaceId = 291
        .Controls(13).BeginGroup = True
        .Controls.Add Type:=msoControlButton
        .Controls(14).Caption = "全ての隠しｼｰﾄを表示する(&F)"
        .Controls(14).OnAction = "全シート表示"
        .Controls(14).FaceId = 2587
        .Controls.Add Type:=msoControlButton
        .Controls(15).Caption = "ｼｰﾄを確認しながら非表示にする(&H)"
        .Controls(15).OnAction = "シート隠蔽"
        .Controls(15).FaceId = 1641
    End With

End Sub

Sub Menu削除(num%)

    Dim myBar  As CommandBar

    Set myBar = CommandBars("Worksheet Menu Bar")
    On Error Resume Next
    myBar.Controls("MyTools(&X)").Delete
    On Error GoTo 0

End Sub


Sub ウィンドウの上下整列()

    Windows.Arrange ArrangeStyle:=xlArrangeStyleHorizontal              'xlArrangeStyleVertical  にすると横に並べて整列

End Sub

Sub 同一Sheetの複数画面表示()

    Dim sBookName As String
    Dim nLen As Integer
    sBookName = ActiveWindow.Caption
    nLen = Len(sBookName)
    ActiveWindow.NewWindow
    If Mid(sBookName, nLen - 1, 1) <> ":" Then
         Windows(sBookName & ":1").Activate
    End If
    Windows.Arrange ArrangeStyle:=xlHorizontal

End Sub

Sub To_Home()

    Dim ws As Variant
    For Each ws In Worksheets
        If Sheets(ws.Name).Visible = True Then
                Sheets(ws.Name).Select
                Range("A1").Select
        End If
    Next
    Sheets(1).Select

End Sub

Sub セル移動方向切替()

    If Application.MoveAfterReturn = False Then
        Application.MoveAfterReturn = True
        Application.MoveAfterReturnDirection = xlDown
        Exit Sub
    End If

    If Application.MoveAfterReturnDirection = xlDown Then
        Application.MoveAfterReturnDirection = xlToRight
    Else
        Application.MoveAfterReturnDirection = xlDown
    End If

End Sub

Sub 枠線表示切替え()

    ActiveWindow.DisplayGridlines = Not (ActiveWindow.DisplayGridlines)

End Sub

Sub 行列番号表示切替()

    ActiveWindow.DisplayHeadings = Not (ActiveWindow.DisplayHeadings)

End Sub

Sub 全シート表示()

    Dim ws As Variant
    For Each ws In Sheets
        Sheets(ws.Name).Visible = True
    Next
    Sheets(1).Select

End Sub

Sub シート隠蔽()

    Dim ws As Variant
    Dim response As Integer
    Dim i As Integer
    Dim cnt As Integer
    cnt = 0

    For Each ws In Sheets
        If Sheets(ws.Name).Visible = True Then '表示されているシートの数
            cnt = cnt + 1
        End If
    Next
    i = 0

    For Each ws In Sheets
        If Sheets(ws.Name).Visible = True Then
            Sheets(ws.Name).Select
            i = i + 1
            response = MsgBox("シート(" & i & ") 【 " & ws.Name & " 】 を隠しますか？" & Chr$(13) & Chr$(13), _
                           vbYesNoCancel + vbQuestion + vbDefaultButton2, "確認！")
            If response = vbYes Then
                If cnt = 1 Then
                    MsgBox "全てのシートを非表示にする事は出来ません！", vbExclamation
                    Exit Sub
                End If
                Sheets(ws.Name).Visible = False
                cnt = cnt - 1
            Else
                If response = vbCancel Then
…