MALICIOUS
370
Risk Score
Malware Insights
MITRE ATT&CK
T1059.005 Visual Basic
T1204.002 Malicious File
The sample is an Excel file containing obfuscated VBA macros designed to execute malicious code. The Workbook_Open event triggers a function that uses WScript.Shell and ShellExecute API calls, indicating an attempt to download and run a secondary payload. The presence of multiple URLs suggests potential C2 communication or payload hosting.
Heuristics 10
-
VBA macros detected medium 6 related findings OLE_VBA_MACROSDocument contains VBA macro code
-
Potential Shell call in VBA critical OLE_VBA_SHELLPotential Shell call in VBAMatched line in script
TextFilename = ThisWorkbook.Path & "\DaProcess\MyTool\NenkouMemo" & ActiveWorkbook.Name & ".dat" Shell "write /p " & TextFilename -
WScript.Shell usage critical OLE_VBA_WSCRIPTWScript.Shell usageMatched line in script
With CreateObject("Wscript.Shell") .Run str -
Obfuscated auto-exec VBA loader critical OLE_VBA_OBFUSCATED_AUTOEXEC_LOADERAuto-exec VBA reconstructs strings with a heavy custom decoder (numeric char-array, repeated hex-string decode, or junk-token Replace removal) and feeds them to a COM-instantiation or execution sink. This obfuscated-loader shape keeps CreateObject/Shell/URL indicators out of the macro source.Matched line in script
lngRet = ShellExecute(0, "Open", pPath & vbNullString, _ vbNullString, vbNullString, SW_SHOWNORMAL) -
CreateObject call high OLE_VBA_CREATEOBJCreateObject callMatched line in script
'Dim item As MyNumberItem Set item = CreateObject(PROG_ID_MyNumberItem) -
VBA p-code auto-exec with execution tokens high OLE_VBA_PCODE_AUTOEXEC_EXECCompiled VBA/cache stream contains an auto-execution token together with shell/download/object-execution tokens. This catches p-code-only or source-extraction-failure macro documents where visible source is unavailable.
-
Workbook_Open macro low OLE_VBA_WBOPENWorkbook_Open macroMatched line in script
End Sub Private Sub Workbook_Open() -
Reference to ShellExecute API high SC_STR_SHELLEXECReference to ShellExecute API
-
Reference to Windows Script Host high SC_STR_WSCRIPTReference to Windows Script Host
-
Embedded URL info EMBEDDED_URLOne or more URLs were extracted from the document. The URL itself is not a detection — see the per-URL labels for which channel (macro, JS, link annotation, document body, ...) reached each URL.URL https://www.cells.co.jp/daityo-s/wp-content/uploads/manual/jigyosyoda.pdf In document text (OLE body)
- https://shinsei2.kn.e-gov.go.jp/Shinsei/main.jsp�In document text (OLE body)
- https://shinsei.e-gov.go.jp/Shinsei/main.jsp�In document text (OLE body)
- https://shinsei.e-gov.go.jp/Shinsei/main.jsp?egovparam=PK011K0001In document text (OLE body)
- https://shinsei2.kn.e-gov.go.jp/Shinsei/main.jspIn document text (OLE body)
- https://shinsei.e-gov.go.jp/Shinsei/main.jspIn document text (OLE body)
Extracted artifacts 1
Files carved from inside the sample during analysis.
| Filename | Kind | Source | Size |
|---|---|---|---|
macros.bas |
vba-macro | oletools.olevba.extract_macros (decoded VBA source) | 731165 bytes |
SHA-256: e4d8b411563a05bfb000c65f334fbbb583fdf9feeff6f2b0348ed951baf2276b |
|||
Preview scriptFirst 1,000 lines of the extracted script
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
Option Explicit
Private Const DEFINE_BASE As Long = 100
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Set myobj = Nothing
End Sub
Private Sub Workbook_Open()
If MNMode(True, False) Then Set myobj = New MyNumber
If NeedDBVersionUp Then DBUP
End Sub
Private Function NeedDBVersionUp() As Boolean
InitDBObjectmy Replace(PathCombine(ThisWorkbook.Path & "\MNRelevance", "Syslog.accdb"), Workbooks("DaMenu.xls").Path & "\", ""), dbCon, DB_PROVIDER_ACE
Dim rec As New ADODB.Recordset
Dim size As Long
rec.Open "Syslog", dbCon, adOpenStatic, adLockReadOnly
size = rec.Fields("Summary").DefinedSize
rec.Close
dbCon.Close
If size <> DEFINE_BASE Then
NeedDBVersionUp = True
Else
NeedDBVersionUp = False
End If
End Function
Private Sub DBUP()
InitDBObjectmy Replace(PathCombine(ThisWorkbook.Path & "\MNRelevance", "Syslog.accdb"), Workbooks("DaMenu.xls").Path & "\", ""), dbCon, DB_PROVIDER_ACE
dbCon.Execute "Alter table syslog alter column Summary text(" & DEFINE_BASE & ")"
dbCon.Execute "Alter table syslog alter column UpdateMachine text(" & DEFINE_BASE & ")"
dbCon.Close
End Sub
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
Option Explicit
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
Option Explicit
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
Option Explicit
Attribute VB_Name = "Class1"
Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
Private WithEvents clsBTN As MSForms.CommandButton
Attribute clsBTN.VB_VarHelpID = -1
Public Property Set Object(setObject As MSForms.CommandButton)
Set clsBTN = setObject
End Property
Public Property Get Object() As MSForms.CommandButton
Set Object = clsBTN
End Property
Private Sub clsBTN_Click() 'インスタンスのClickイベント
Dim Temp1 As Integer
Dim Temp2 As Integer
Dim j As Integer
With カレンダー.SpinButton1
Temp1 = (.Value - 1) \ 12 + 1
Temp2 = (.Value - 1) Mod 12 + 1
End With
If カレンダー.Label9.Caption = "個人情報F" Then
個人情報F.Controls(カレンダー.Label8.Caption).Value = DateValue(Temp1 & "/" & Temp2 & "/" + clsBTN.Caption)
If カレンダー.Label8.Caption = "Text15" Then
Dim Myko As Integer
Dim MyKu As Integer
Myko = Val(個人情報F.ListBox1.Text) '個人情報の行番号
MyKu = Val(個人情報F.LaKD.Caption) '給与データの行番号
If MsgBox("この退社年月日を社保喪失日と雇保離職日にも登録しますか？", 4 + 32, "登録") = 6 Then
With Worksheets("個人情報")
If IsDate(.Cells(Myko, 27).Value) Then
.Cells(Myko, 28).Value = DateValue(Temp1 & "/" & Temp2 & "/" + clsBTN.Caption) + 1
End If
If IsDate(.Cells(Myko, 29).Value) Then
.Cells(Myko, 30).Value = DateValue(Temp1 & "/" & Temp2 & "/" + clsBTN.Caption)
End If
End With
If MyKu > 0 Then
With Worksheets("給与データ")
If IsDate(.Cells(MyKu, 13).Value) Then
.Cells(MyKu, 14).Value = DateValue(Temp1 & "/" & Temp2 & "/" + clsBTN.Caption) + 1
End If
If IsDate(.Cells(MyKu, 15).Value) Then
.Cells(MyKu, 16).Value = DateValue(Temp1 & "/" & Temp2 & "/" + clsBTN.Caption)
End If
End With
End If
End If
End If
ElseIf カレンダー.Label9.Caption = "一括有期F" Then
一括有期F.Controls(カレンダー.Label8.Caption).Value = DateValue(Temp1 & "/" & Temp2 & "/" + clsBTN.Caption)
Else
新規.Controls(カレンダー.Label8.Caption).Value = DateValue(Temp1 & "/" & Temp2 & "/" + clsBTN.Caption)
End If
DoEvents
Unload カレンダー
End Sub
Attribute VB_Name = "Da保存"
Attribute VB_Base = "0{9E2A6A5F-EA3E-4E34-A843-F75E62016FB1}{5FFB926B-09EF-46D1-8800-67C6E662061D}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
Option Explicit
Dim Kara As String
''' 保存データで、クリアしたい範囲を設定する
''' 範囲は、Rangeに渡す引数
Private mClearArea As String
Public Property Get ClearArea() As String
ClearArea = mClearArea
End Property
Public Property Let ClearArea(ByVal vNewValue As String)
mClearArea = vNewValue
End Property
Private Sub UserForm_Initialize()
Application.ScreenUpdating = True
Me.Caption = ActiveSheet.Name & "の保存"
TextBox1.SetFocus
TextBox1.SelStart = 0
TextBox1.SelLength = TextBox1.TextLength
On Error GoTo ErrorC
Kara = ""
If Right(Worksheets("DATA").Cells(1, 1).Value, 6) = "da.xls" Then
Kara = "Zi"
End If
Exit Sub
ErrorC:
End Sub
Private Sub UserForm_Activate()
On Error Resume Next
Kill Workbooks("DaMenu.xls").Path & "\HozonName.dat"
End Sub
Private Sub CommandButton1_Click()
'#39615 ito 20180313 xlsm対応のためファイル出力と同じ形式に変更 ----------------------------------------------------------------------------------------------------------------------------------------------------
' Dim 保存ファイル名 As String
' Dim ファイル区分 As String
' Dim MyFile As String
' Dim 台帳ファイル名 As String
' Dim シート名 As String
' '20080214 kon
'' Dim 開始範囲 As String
'' Dim 終了範囲 As String
'
' If Trim(TextBox1.Value) = "" Then
' MsgBox "ファイル名を入力してから実行してください。", 16, "保存"
' Exit Sub
' End If
' If TextBox1.Value Like "*[\/:*?""'#<>|]*" Then
' MsgBox TextBox1.Value & " は無効なファイル名です", 16, "保存"
' Exit Sub
' End If
' If Dir(ActiveWorkbook.Path & "\Da保存", 16) = "" Then MkDir ActiveWorkbook.Path & "\Da保存" '保存台帳フォルダがなかったら作成する
' シート名 = ActiveSheet.Name
' MyFile = ActiveWorkbook.Name
'
' If Kara = "Zi" Then '事業所台帳からの保存とファイル区分が違う
' With Worksheets("DATA")
' 台帳ファイル名 = .Cells(1, 1).Value
' ファイル区分 = " " & Left(MyFile, Len(MyFile) - 4) & " " & Left(.Cells(1, 1).Value, Len(.Cells(1, 1).Value) - 4) & " " & ActiveSheet.Name & ".xls" '会社名＋現在日付で保存する
' End With
' Else
' ファイル区分 = " " & Left(MyFile, Len(MyFile) - 4) & " " & ActiveSheet.Name & ".xls" 'ブック名＋シート名で保存する
' End If
' 保存ファイル名 = TextBox1.Value & " " & ファイル区分
'
' Dim フルパス As String
' フルパス = ActiveWorkbook.Path & "\Da保存\" & 保存ファイル名
' If 保存ファイル名 = Dir(フルパス) Then 'すでにあるかチェック
' If MsgBox("この保存ファイルはすでに存在します。上書きしますか？", 1 + 48, aaa) <> 1 Then
' MsgBox "処理を中止します。", 64, aaa
' Exit Sub
' End If
' End If
'
' If MsgBox("ファイル名「" & TextBox1.Value & "」を作成します。よろしいですか？", 1 + 32, aaa) <> 1 Then Exit Sub
' Application.ScreenUpdating = False
' Application.DisplayAlerts = False
' Dim 印刷範囲 As String
' Application.ReferenceStyle = xlA1
' '20080214 kon
' '20080130 kon
'' If ActiveSheet.PageSetup.PrintArea = "" Then
'' ActiveSheet.PageSetup.PrintArea = Range(Cells(1, 1), Cells(ActiveSheet.UsedRange.SpecialCells(xlLastCell).Row, ActiveSheet.UsedRange.SpecialCells(xlLastCell).Column)).Address
'' 印刷範囲 = ActiveSheet.PageSetup.PrintArea
'' Else
'' 開始範囲 = Range(ActiveSheet.PageSetup.PrintArea).Row() & ":" & Range(ActiveSheet.PageSetup.PrintArea).Column()
'' 終了範囲 = Range(ActiveSheet.PageSetup.PrintArea).Rows.Count & ":" & Range(ActiveSheet.PageSetup.PrintArea).Columns.Count
'' 印刷範囲 = Range(開始範囲, 終了範囲).Address
'' End If
' If ActiveSheet.PageSetup.PrintArea = "" Then
' 印刷範囲 = "$A$1:" & Cells(1, 1).SpecialCells(xlCellTypeLastCell).Address
' Else
' 印刷範囲 = Hani(ActiveSheet.PageSetup.PrintArea)
' End If
'
'
'' 印刷範囲 = ActiveSheet.PageSetup.PrintArea
'' 印刷範囲を再設定 20080130 kon ４行目から上にタイトルがある場合が多いのであえて４行目から
'' 印刷範囲 = Range(Cells(4, 1), Cells(ActiveSheet.UsedRange.SpecialCells(xlLastCell).Row, ActiveSheet.UsedRange.SpecialCells(xlLastCell).Column)).Address
'' 印刷範囲 = ActiveSheet.PageSetup.PrintArea
'
' Label4.Caption = "データをコピーしています・・"
' Me.Repaint
' Workbooks.Open ActiveWorkbook.Path & "\NewKeepFile.xls"
' Workbooks(MyFile).Worksheets(シート名).Copy Before:=ActiveWorkbook.Sheets(1) 'シートをコピーする
' ActiveSheet.Unprotect
' ActiveSheet.Name = "COPY" 'シートを名前をCOPYとする
' Dim wRange As Range '印刷範囲以外のオブジェクトと印刷範囲内のマクロ付のオブジェクトを削除する
' Dim wLeft, wTop, wRight, wBottom
' Dim shapeLeft, shapeTop, shapeRight, shapeBottom
' Dim s As Shape
' With Range(印刷範囲)
' wTop = .Top
' wLeft = .Left
' wBottom = .Top + .Height
' wRight = .Left + .Width
' End With
'
' For Each s In ActiveSheet.Shapes
' shapeTop = s.Top
' shapeLeft = s.Left
' shapeBottom = s.Top + s.Height
' shapeRight = s.Left + s.Width
' If s.Name Like "Drop*" Then
' Else
' If (wTop <= shapeTop And wLeft <= shapeLeft And _
' wBottom >= shapeBottom And wRight >= shapeRight) And s.OnAction = "" Then
' Else
' s.Delete
' End If
' End If
' Next
' DoEvents '#35374
' Cells.Copy
' DoEvents '#35374
' Cells.PasteSpecial Paste:=xlValues '数式をすべて値にする
' DoEvents '#35374
' Range(印刷範囲).Value = Workbooks(MyFile).Worksheets(シート名).Range(印刷範囲).Value2
' Sheets("Info").Select
' ActiveSheet.Shapes("BOTAN").Select
' Selection.Cut
' Sheets("COPY").Select
' Range("A1").Select
' DoEvents '#35374
' ActiveSheet.Paste
' DoEvents '#35374
' Range("A1").Select
'
' Application.CutCopyMode = False
' With Worksheets("Info")
' .Cells(1, 1).Value = ファイル区分
' .Cells(2, 1).Value = MyFile
' If Kara = "Zi" Then
' .Cells(3, 1).Value = 台帳ファイル名
' End If
' .Cells(4, 1).Value = シート名
' .Cells(5, 1).Value = 保存ファイル名
' .Cells(6, 1).Value = TextBox1.Value
' .Cells(7, 1).Value = Now
' End With
' Label4.Caption = "保存しています・・"
' Me.Repaint
'
' 'クリアしたいエリアがあれば、その範囲をクリアする
' If mClearArea <> vbNullString Then
' ActiveWorkbook.ActiveSheet.Range(mClearArea).ClearContents
' End If
'
' ActiveWorkbook.SaveAs フルパス '保存する
' ActiveWorkbook.Close False
' Workbooks(MyFile).Activate
' Label4.Caption = ""
' Me.Repaint
' MsgBox "「保存データ」を作成しました。", 64, aaa
' Application.DisplayAlerts = True
' Application.ScreenUpdating = True
' Range("A1").Select
'
' Unload Me
Dim HozonFileName As String
Dim HozonFilePath As String
Dim SheetName As String
Dim Extension As String
Dim FileName As String
Dim FileType As String
Dim MyFile As String
Dim daName As String
Dim ws As Worksheet
Dim s As Shape
If Trim(TextBox1.Value) = "" Then
MsgBox "ファイル名を入力してから実行してください。", 16, "保存"
Exit Sub
End If
If TextBox1.Value Like "*[\/:*?""'#<>|]*" Then
MsgBox TextBox1.Value & " は無効なファイル名です", 16, "保存"
Exit Sub
End If
If Dir(ActiveWorkbook.Path & "\Da保存", 16) = "" Then MkDir ActiveWorkbook.Path & "\Da保存" '保存台帳フォルダがなかったら作成する
SheetName = ActiveSheet.Name
MyFile = ActiveWorkbook.Name
'拡張子判定
If Right(ActiveWorkbook.Name, 4) = "xlsm" Then 'xlsmの処理ファイルの場合
Extension = ".xlsm"
FileName = " " & Left(MyFile, Len(MyFile) - 5)
Else 'xlsの処理ファイルの場合
Extension = ".xls"
FileName = " " & Left(MyFile, Len(MyFile) - 4)
End If
'事業所台帳からの保存とFileTypeが違う
If Kara = "Zi" Then
daName = Worksheets("DATA").Cells(1, 1).Value
FileType = FileName & " " & Left(daName, Len(daName) - 4) & " " & ActiveSheet.Name '会社名＋現在日付で保存する
Else
FileType = FileName & " " & ActiveSheet.Name 'ブック名＋シート名で保存する
End If
HozonFileName = TextBox1.Value & " " & FileType
HozonFilePath = ActiveWorkbook.Path & "\Da保存\" & HozonFileName
If HozonFileName = Dir(HozonFilePath & Extension) Or Dir(HozonFilePath & ".xlsx") <> "" Then 'すでにあるかチェック
If MsgBox("この保存ファイルはすでに存在します。上書きしますか？", 1 + 48, aaa) <> 1 Then
MsgBox "処理を中止します。", 64, "保存"
Exit Sub
End If
End If
If MsgBox("書類名「" & TextBox1.Value & "」を作成します。よろしいですか？", 1 + 32, aaa) <> 1 Then Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
ActiveWorkbook.SaveCopyAs FileName:=HozonFilePath & Extension
Workbooks.Open HozonFilePath & Extension
Application.Calculation = xlCalculationManual
ActiveSheet.Unprotect
Cells.Copy
Cells.PasteSpecial Paste:=xlPasteValues
Application.Calculation = xlCalculationAutomatic
For Each ws In Worksheets
If ws.Name <> SheetName Then
ws.Delete
End If
Next
ActiveWindow.DisplayWorkbookTabs = True
ActiveWindow.TabRatio = 0.5
'クリアしたいエリアがあれば、その範囲をクリアする
If mClearArea <> vbNullString Then
ActiveSheet.Range(mClearArea).ClearContents
End If
'余分なフォームコントロールを削除
'#40595 ito 20180406
'For Each s In ActiveSheet.Shapes
' If s.Type = msoFormControl Then 'マクロ付きと上の方のオブジェクトとフォームコントロール
' s.Delete
' End If
'Next
'For Each s In ActiveSheet.Shapes
' If s.OnAction <> "" Or s.Top < 40 Then
' s.Delete
' End If
'Next
Dim 印刷範囲 As String
Application.ReferenceStyle = xlA1
If ActiveSheet.PageSetup.PrintArea = "" Then
印刷範囲 = "$A$1:" & Cells(1, 1).SpecialCells(xlCellTypeLastCell).Address
Else
印刷範囲 = Hani(ActiveSheet.PageSetup.PrintArea)
End If
Dim wRange As Range '印刷範囲以外のオブジェクトと印刷範囲内のマクロ付のオブジェクトを削除する
Dim wLeft, wTop, wRight, wBottom
Dim shapeLeft, shapeTop, shapeRight, shapeBottom
With Range(印刷範囲)
wTop = .Top
wLeft = .Left
wBottom = .Top + .Height
wRight = .Left + .Width
End With
For Each s In ActiveSheet.Shapes
shapeTop = s.Top
shapeLeft = s.Left
shapeBottom = s.Top + s.Height
shapeRight = s.Left + s.Width
If s.Name Like "Drop*" Then
Else
If (wTop <= shapeTop And wLeft <= shapeLeft And _
wBottom >= shapeBottom And wRight >= shapeRight) And s.OnAction = "" Then
Else
s.Delete
End If
End If
Next
Cells(1, 1).Select
ActiveWorkbook.SaveAs FileName:=HozonFilePath & ".xlsx", FileFormat:=xlOpenXMLWorkbook 'xlsxで保存しなおす
Kill HozonFilePath & Extension '元ブックのコピー削除
ActiveWorkbook.Close False
Application.CutCopyMode = False
Application.DisplayAlerts = True
Application.EnableEvents = True
Workbooks(MyFile).Activate
MsgBox "「保存データ」を作成しました。", 64, aaa
Application.ScreenUpdating = True
Cells(1, 1).Select
Unload Me
'#39615 -----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
End Sub
Attribute VB_Name = "KozinJouho"
Option Explicit
'*********20150511 kon マイナンバー
Public myobj As New MyNumber
Public RANGE_ARIA As String
'20151210 kon 扶養追加
'Public strMyNo(7) As String
Public strMyNo(11) As String
Public errorNo() As String
Public dic As Object '20150515 KON マイナンバー
Public Const LIST_INPUT_FILENAME As String = "一覧入力.xlsm"
Public Const MSG_CELLS_DRIVE_NOT_READY As String = "Cellsドライブの設定がされていません。"
Private Const PROG_ID_MyNumberClientInterop As String = "CellsDriveInterop.MyNumber.MyNumberClientInterop"
Private Const PROG_ID_MyNumberItem As String = "Cells.CellsDriveLib.MyNumber.Serialization.MyNumberItem"
'*********end
Sub 個人情報へ()
個人情報F.Show 0
End Sub
Sub 一括有期へ()
Sheets("一括有期データ").Select
'YBNO 28387 ito 20150728 IF文追加
If Cells(4, 5).Value = "" Then
'YBNO 28152 ito 20150723 文言表示 -------------------------------------------------------------------
ActiveSheet.Unprotect
Cells(4, 5).Select
Cells(4, 5).Value = "※平成27年3月31日以前の事業は消費税を含めた請負金額、平成27年4月1日以降に開始した事業は消費税額を除く請負金額となっているか確認してください｡ "
With Selection
.HorizontalAlignment = xlGeneral
.ShrinkToFit = False
End With
With Selection.Font
.size = 9
End With
With ActiveCell.Characters(Start:=30, length:=19).Font
.Color = -16776961
End With
With ActiveCell.Characters(Start:=49, length:=11).Font
.Underline = xlUnderlineStyleSingle
End With
Cells(2, 3).Select
ActiveSheet.Unprotect
'YBNO 28152 ito 20150723 ここまで -------------------------------------------------------------------
End If
一括有期F.Show
End Sub
Sub 給与データの計()
Dim i As Integer
Dim n As Integer
'20160603 kon 32064
With Sheets("給与データ")
n = .Cells(10000, 7).End(xlUp).Row + 2
Application.Calculation = xlManual
For i = 8 To n '横計（個人別）
.Cells(i, 33).Value = WorksheetFunction.Sum(.Range(.Cells(i, 17), .Cells(i, 32)))
Next
For i = 17 To 33 '縦計（月別）
.Cells(6, i).Value = WorksheetFunction.Sum(.Range(.Cells(8, i), .Cells(n, i)))
.Cells(5, i).Value = WorksheetFunction.count(.Range(.Cells(8, i), .Cells(n, i)))
Next
.Cells(5, 33).Value = WorksheetFunction.CountIf(.Range(.Cells(8, 33), .Cells(n, 33)), ">0")
End With
' n = Cells(10000, 7).End(xlUp).Row + 2
' Application.Calculation = xlManual
' For i = 8 To n '横計（個人別）
' Cells(i, 33).Value = WorksheetFunction.Sum(Range(Cells(i, 17), Cells(i, 32)))
' Next
' For i = 17 To 33 '縦計（月別）
' Cells(6, i).Value = WorksheetFunction.Sum(Range(Cells(8, i), Cells(n, i)))
' Cells(5, i).Value = WorksheetFunction.count(Range(Cells(8, i), Cells(n, i)))
' Next
' Cells(5, 33).Value = WorksheetFunction.CountIf(Range(Cells(8, 33), Cells(n, 33)), ">0")
Application.Calculation = xlAutomatic
End Sub
'20150407 kon マイナンバー
Sub Preview(pPath As String)
Dim strPath As String
Dim lngRet As Long
Dim Manu As String
lngRet = ShellExecute(0, "Open", pPath & vbNullString, _
vbNullString, vbNullString, SW_SHOWNORMAL)
Select Case lngRet
Case SE_ERR_NOASSOC
MsgBox "ファイルを開くことができません。", 16, aaa
Case ERROR_FILE_NOT_FOUND
MsgBox "ファイルが見つかりません。", 16, aaa
End Select
End Sub
'**********************************************************
'取得したマイナンバーを取り出す(個人情報個別編集用)
'
'**********************************************************
Sub SetMyNumberK(ByRef dic As Object, gCnt As Long)
Dim i As Long
Dim buf As Variant
Dim item As Object
'Dim item As MyNumberItem
With Worksheets("個人情報")
For Each buf In .Range(RANGE_ARIA)
'20151125 kon 扶養家族
' For i = 1 To 7
For i = 1 To 11
If .Cells(gCnt, 199 + i).Value = buf.Value Then
If dic.exists(LCase(buf.Value)) Then
Set item = dic.item(LCase(buf.Value))
frmNo.Controls("TextBox" & i).Text = item.myno
Exit For
End If
End If
Next
Next
End With
End Sub
'**********************************************************
'取得したマイナンバーを取り出す(個人情報一覧編集用)
'
'**********************************************************
Sub SetMyNumberL(ByRef dic As Object, gCnt As Long)
Dim i As Long
Dim buf As Variant
'Dim item As MyNumberItem
Dim item As Object
'#30393 hara 20160413 抽出の高速化
Dim guid As String
Dim result As Double
i = 1
With Workbooks(Workbooks(LIST_INPUT_FILENAME).Worksheets("Data").Cells(1, 1).Value).Worksheets("個人情報")
'#30393 hara 20160413 抽出の高速化
' For Each buf In .Range(RANGE_ARIA)
'20151210 kon 扶養追加
' For i = 1 To 7
For i = 1 To 11
guid = .Cells(gCnt, 199 + i).Value
result = WorksheetFunction.CountIf(.Range(RANGE_ARIA), guid)
' If .Cells(gCnt, 199 + i).Value = buf.Value Then
If guid <> "" And result = 1 Then
If dic.exists(LCase(guid)) Then
' If dic.Exists(LCase(buf.Value)) Then
' Set item = dic.item(LCase(buf.Value))
Set item = dic.item(LCase(guid))
strMyNo(i) = item.myno
Else
strMyNo(i) = ""
End If
Else
strMyNo(i) = ""
' Exit For
End If
Next i
' Next buf
End With
End Sub
'**********************************************************
'取得したマイナンバーを取り出す(個人情報表記用)
'
'**********************************************************
Sub SetMyNumber(ByRef dic As Object, gCnt As Long)
Dim i As Long
Dim buf As Variant
i = 1
With Worksheets("個人情報")
'クリア
'20151125 kon 扶養家族
' For i = 1 To 7
'taka 20151118 huyou
' For i = 1 To 10
' 個人情報F.Controls("TextBox" & i + 65).Text = ""
' Next i
' For Each buf In .Range(RANGE_ARIA)
''20151125 kon 扶養家族
'' For i = 1 To 7
' For i = 1 To 10
' If .Cells(gCnt, 199 + i).Value = UCase(buf.Value) Then
' If dic.Exists(LCase(buf.Value)) Then
' 個人情報F.Controls("TextBox" & i + 65).Text = "************"
' Else
' 個人情報F.Controls("TextBox" & i + 65).Text = vbNullString
' End If
' End If
' Next i
' Next
i = 0
For Each buf In .Range(RANGE_ARIA)
If .Cells(gCnt, 200 + i).Value = UCase(buf.Value) Then
If i = 0 Then
If dic Is Nothing Then
個人情報F.TextBox66.Text = vbNullString
Else
If dic.exists(LCase(buf.Value)) Then
個人情報F.TextBox66.Text = "************"
Else
個人情報F.TextBox66.Text = vbNullString
End If
End If
Else
If 個人情報F.Hlist.Selected(i - 1) = True Then
If .Cells(gCnt, 200 + i).Value = UCase(buf.Value) Then
If dic Is Nothing Then
個人情報F.TextBox67.Text = vbNullString
Else
If dic.exists(LCase(buf.Value)) Then
個人情報F.TextBox67.Text = "************"
Else
個人情報F.TextBox67.Text = vbNullString
End If
End If
Exit For ' 選択した人が見つかった状態で終わらないと、Textboxの状態が維持されないので、他の人の情報が表示される。
End If
End If
End If
End If
i = i + 1
Next
'-------------------------------------------------------------------------------------/
End With
End Sub
'**********************************************************
'マイナンバーを有無
'
'**********************************************************
Function chkSetMyNumber(ByRef dic As Object, gCnt As Long, wb As String, RANGE_ARIA As String) As Boolean
Dim i As Long
Dim buf As Variant
i = 1
With Workbooks(wb).Worksheets("個人情報")
For Each buf In .Range(RANGE_ARIA)
'20151125 kon 扶養家族
' For i = 1 To 7
For i = 1 To 11
If .Cells(gCnt, 199 + i).Value = buf.Value Then
If dic.exists(LCase(buf)) Then
chkSetMyNumber = True
Exit Function
End If
End If
Next i
Next
End With
chkSetMyNumber = False
End Function
'*********20150511 kon マイナンバー
'取り出す
Sub SetDic(ByRef dic As Object, ByRef items() As Object)
'Sub SetDic(ByRef dic As Object, ByRef items() As MyNumberItem)
Dim i As Long
Dim buf As Variant
Dim item As Object
'Dim item As MyNumberItem
Set item = CreateObject(PROG_ID_MyNumberItem)
dic.RemoveAll
If Not Sgn(items) <> 0 Then Exit Sub
For Each buf In items
Set item = buf
If item.Systemkey <> vbNullString Then
dic.add LCase(item.Systemkey), item
End If
Next
End Sub
'20151214 kon 扶養追加
'Sub 個人番号一覧入力抽出(op1 As Boolean, op2 As Boolean, op4 As Boolean, da As String, mon As String, ck As Boolean)
'Sub 個人番号一覧入力抽出(op1 As Boolean, op2 As Boolean, op4 As Boolean, op5 As Boolean, da As String, mon As String, ck As Boolean)
Sub 個人番号一覧入力抽出(op1 As Boolean, op2 As Boolean, op4 As Boolean, op5 As Boolean, da As String, mon As String, ck As Boolean, ck2 As Boolean, ck3 As Boolean)
'30393 20160413 hara 抽出条件の追加
Dim daName As String
Dim i As Long
Dim ii As Long
Dim gNo As Long
Dim dic As Object
Dim items() As Object
'Dim items() As MyNumberItem
Dim ret As Boolean
Dim hgNo As Range '20151214 kon 扶養追加
Dim hNo As Long '20151214 kon 扶養追加
Dim icnt As Long
Dim rcnt As Long
'30393 20160413 hara
Dim count As Long
Dim j As Long 'ループ変数
Dim ws一覧入力 As Worksheet
Set ws一覧入力 = Workbooks(LIST_INPUT_FILENAME).Worksheets("一覧入力")
'20151002 kon 28970
' On Error Resume Next
' InitDBObjectmy Replace(PathCombine(ThisWorkbook.Path & "\MNRelevance", "Syslog.accdb"), Workbooks("DaMenu.xls").Path & "\", ""), dbCon, DB_PROVIDER_ACE
' On Error GoTo 0
'データをクリアする
Workbooks(LIST_INPUT_FILENAME).Sheets("Data").Range("A3").Value = 1
Workbooks(LIST_INPUT_FILENAME).Sheets("Data").Range("A2").Value = ""
Application.ScreenUpdating = False
gNo = ws一覧入力.Cells(50000, 3).End(xlUp).Row + 20
'20151214 kon 扶養追加
' Workbooks(LIST_INPUT_FILENAME).Worksheets("一覧入力").Range("B4:Y" & IIf(gNo > 4, gNo, 4)).ClearContents
ws一覧入力.Range("B4:AK" & IIf(gNo > 4, gNo, 4)).ClearContents
gNo = Workbooks(LIST_INPUT_FILENAME).Worksheets("不一致").Cells(50000, 1).End(xlUp).Row
Workbooks(LIST_INPUT_FILENAME).Worksheets("不一致").Range("A4:Y" & IIf(gNo > 3, gNo, 4)).ClearContents
daName = Workbooks(LIST_INPUT_FILENAME).Sheets("Data").Cells(1, 1).Value
ii = 4
With Workbooks(daName).Worksheets("個人情報")
gNo = .Cells(50000, 2).End(xlUp).Row
'20160125 kon 29973
'20160215 kon
Workbooks(daName).Worksheets("扶養データ").Unprotect
Workbooks(daName).Worksheets("扶養データ").Visible = True
Workbooks(daName).Worksheets("扶養データ").Rows.Columns(1).Hidden = False
For i = 6 To gNo
DoEvents
'Application.Run LIST_INPUT_FILENAME & "!pr", gNo, i #28996
'マイナンバー未入力
'けんぽＮＯ取得日があって喪失日がない
If op1 = True Then
If .Cells(i, 27).Value <> "" Then
If .Cells(i, 28).Value <> "" Then
ws一覧入力.Cells(ii, 2).Value = 1
End If
Else
ws一覧入力.Cells(ii, 2).Value = 1
End If
'雇用保険取得日があって喪失日がない
End If
If op2 = True Then
If .Cells(i, 29).Value <> "" Then
If .Cells(i, 30).Value <> "" Then
ws一覧入力.Cells(ii, 2).Value = 1
End If
Else
ws一覧入力.Cells(ii, 2).Value = 1
End If
End If
'退職日
If op4 = True Then
If .Cells(i, 15).Value >= CDate(da) And .Cells(i, 15).Value <= DateAdd("m", Val(mon), da) Then
Else
ws一覧入力.Cells(ii, 2).Value = 1
End If
End If
'退職者以外 ’20151214 kon 29692
If op5 = True Then
' If .Cells(i, 14).Value <> "" And .Cells(i, 15).Value = "" Then
'#30484 hara 20160413 退職日のみで判定する
If .Cells(i, 15).Value = "" Then
Else
ws一覧入力.Cells(ii, 2).Value = 1
End If
End If
'********************起動時取得した一覧からマイナンバーの存在確認 20150515 kon マイナンバー end
'台帳NO 社員NO
ws一覧入力.Cells(ii, 3).Value = .Cells(i, 2)
ws一覧入力.Cells(ii, 4).Value = .Cells(i, 3)
'本人 5,6
ws一覧入力.Cells(ii, 6).Value = .Cells(i, 5) & " " & .Cells(i, 6)
ws一覧入力.Cells(ii, 5).Value = .Cells(i, 200)
Set hgNo = Workbooks(daName).Worksheets("扶養データ").Columns("A:A").Find(What:=.Cells(i, 200).Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not hgNo Is Nothing Then
hNo = hgNo.Row
rcnt = 1
count = 0
For icnt = 4 To 202 Step 22
'扶養1 (配偶者)
ws一覧入力.Cells(ii, 6 + rcnt * 3).Value = Workbooks(daName).Worksheets("扶養データ").Cells(hNo, icnt) & " " & Workbooks(daName).Worksheets("扶養データ").Cells(hNo, icnt + 1)
ws一覧入力.Cells(ii, 5 + rcnt * 3).Value = .Cells(i, 200 + rcnt)
'#30393 20160413 hara---------------------
If ck3 Then
'扶養者に抹消日が登録されている場合は名前に印をつける
If Workbooks(daName).Worksheets("扶養データ").Cells(hNo, 12 + 22 * count) <> "" Then
ws一覧入力.Cells(ii, 6 + rcnt * 3).Value = "." & Workbooks(daName).Worksheets("扶養データ").Cells(hNo, icnt) & " " & Workbooks(daName).Worksheets("扶養データ").Cells(hNo, icnt + 1)
End If
End If
count = count + 1
rcnt = rcnt + 1
'#30393 end---------------------
Next icnt
End If
ii = ii + 1
次へ:
Next i
Erase strMyNo
'20151009 kon
' RANGE_ARIA = "GR" & 4 & ":GX" & gNo
'taka 20151204 huyou
RANGE_ARIA = "GR" & 6 & ":HB" & gNo
'20151214 kon 扶養追加
' Dim hNo As Long
ret = myobj.Reference(RangeToCollection(.Range(RANGE_ARIA)), items)
If myobj.Authenticated Then
'認証したので、ログを書く
If ret Then
'成功ログ
Application.Run "cellsdrive.xlam!LogWrite", myobj, Workbooks(Workbooks("一覧入力.xlsm").Worksheets("Data").Cells(1, 1).Value).Worksheets("会社情報").Cells(4, 2).Value, Workbooks(Workbooks("一覧入力.xlsm").Worksheets("Data").Cells(1, 1).Value).Worksheets("会社情報").Cells(8, 2).Value, "一覧入力", "ログイン認証", "成功"
Else
'失敗ログ
Application.Run "cellsdrive.xlam!LogWrite", myobj, Workbooks(Workbooks("一覧入力.xlsm").Worksheets("Data").Cells(1, 1).Value).Worksheets("会社情報").Cells(4, 2).Value, Workbooks(Workbooks("一覧入力.xlsm").Worksheets("Data").Cells(1, 1).Value).Worksheets("会社情報").Cells(8, 2).Value, "一覧入力", "ログイン認証", "認証エラー"
Application.Run "cellsdrive.xlam!MessageBox", myobj.LastError
End If
End If
If myobj.accessRight = 0 Then
MsgBox "機密取扱権限がありません。", vbInformation, "アクセス権限"
Exit Sub
End If
If Not ret Then Exit Sub
Set dic = CreateObject("Scripting.Dictionary")
SetDic dic, items
'#28996
Dim frm As New ProgressBar
Load frm
frm.MaxValue = gNo - 5
frm.Show vbModeless
'#28966 END
For i = 6 To gNo + 1 '#29173 20151021 ishikawa
'DoEvents
frm.Value = i - 5 '#28966
'********************起動時取得した一覧からマイナンバーの存在確認 20150515 kon マイナンバー
'20151009 kon
If ck = True Then
'20160210 kon 30248
'#30393 hara 20160412 hara 以下の2行をコメントアウト
' If Cells(ii, 7).Value <> "" Then
' Cells(ii, 2).Value = 1
For j = 6 To 36 Step 3
'名前が登録されていて、マイナンバーの登録がない場合
If Trim(Cells(ii, j).Value) <> "" And Trim(Cells(ii, j + 1).Value) = "" Then
Exit For
End If
Next
'扶養10まで閲覧したら全員登録済とみなす(初回の処理は飛ばす)
If j >= 39 And i <> 6 Then
Cells(ii, 2).Value = 1
End If
End If
'#30393 end
'#30315 ↓2行をコメントに 20160315 ishikawa
' Else
' Cells(ii, 2).Value = ""
' End If
' Else
If HshChk(daName, i, 2) = False Then
Exit Sub
End If
'20151211 kon 扶養追加
Workbooks("一覧入力.xlsm").Activate
'********************起動時取得した一覧からマイナンバーの存在確認 20150515 kon マイナンバー end
'一致したGUIDのマイナンバーを表示
SetMyNumberL dic, i
'本人
Cells(i - 2, 7).Value = strMyNo(1)
'扶養1
Cells(i - 2, 10).Value = strMyNo(2)
'扶養2
Cells(i - 2, 13).Value = strMyNo(3)
'扶養3
Cells(i - 2, 16).Value = strMyNo(4)
'扶養4
Cells(i - 2, 19).Value = strMyNo(5)
'扶養5
Cells(i - 2, 22).Value = strMyNo(6)
'扶養6
Cells(i - 2, 25).Value = strMyNo(7)
'20151214 kon 扶養追加
'扶養7
Cells(i - 2, 28).Value = strMyNo(8)
'扶養8
Cells(i - 2, 31).Value = strMyNo(9)
'扶養9
Cells(i - 2, 34).Value = strMyNo(10)
'扶養10
Cells(i - 2, 37).Value = strMyNo(11)
ii = i - 2
Next i
'#28966
Unload frm
Set frm = Nothing
'End #28966
'条件外データ削除
'20160215 kon 30273
For i = Cells(50000, 6).End(xlUp).Row To 4 Step -1
…
|
|||
Open this report in the interactive analyzer, or submit your own file for analysis.