| |
八家九僧陀 さん
はじめまして、こたつねこと申します。
すでにUO3 さんから回答がありますが、作ってみたのでUPします。
Dictionaryを使った例・・・動作検証はしていませんのバグがある可能性があります。
Public Sub Sample()
Const C_SHT_DATA As String = "年調DATA"
Const C_SHT_POST As String = "最終支給台帳"
Const C_MSG_COMPLETE As String = "処理完了"
Dim EntryDic As Object
Dim Msg As String
Dim Ret As Boolean
Set EntryDic = CreateObject("Scripting.Dictionary")
Ret = AcquisitionData(C_SHT_DATA, EntryDic, Msg)
If (Ret) Then Ret = PostData(C_SHT_POST, EntryDic, Msg)
If (Ret) Then
MsgBox "処理完了", vbOKOnly
Else
MsgBox Msg, vbCritical
End If
Set EntryDic = Nothing
End Sub
'転記する処理
Private Function PostData( _
ByVal SheetName As String _
, ByRef Dic As Object _
, ByRef Msg As String) As Boolean
On Error GoTo Err_Function
Const C_COL_ID As String = "A"
Const C_COL_TAX As String = "CO"
Const C_COL_SOCIAL As String = "BZ"
Const C_COL_DEDUCTION_C As String = "CB"
Const C_COL_DEDUCTION_F As String = "CC"
Const C_COL_INSURANCE As String = "CQ"
Const C_COL_CITIZENS As String = "CP"
Const C_COL_SUPPLIED_B As String = "CR"
Const C_COL_SUPPLIED_T As String = "BL"
Const C_ROW_START As Long = 2
Const C_ERR_MSG As String = "該当するデータがありませんでした。"
Dim Ret As Boolean
Dim Sht As Excel.Worksheet
Dim Row As Long
Dim IdNumber As String
Dim Social As Currency
Dim Deduction_C As Currency
Dim Deduction_F As Currency
Dim Tax As Currency
Dim Citizens As Currency
Dim Supplied_T As Currency
Dim Supplied_B As Currency
Dim Insurance As Currency
Dim HitCNT As Long
Set Sht = ThisWorkbook.Sheets(SheetName)
HitCNT = 0
For Row = C_ROW_START To Sht.Cells(Sht.Rows.Count, 1).End(xlUp).Row
IdNumber = Sht.Range(C_COL_ID & Row).Value
If (Dic.Exists(IdNumber)) Then
HitCNT = HitCNT + 1
Social = Sht.Range(C_COL_SOCIAL & Row).Value
Deduction_C = Sht.Range(C_COL_DEDUCTION_C & Row).Value
Deduction_F = Sht.Range(C_COL_DEDUCTION_F & Row).Value
Citizens = Sht.Range(C_COL_CITIZENS & Row).Value
Supplied_T = Sht.Range(C_COL_SUPPLIED_T & Row).Value
Tax = Dic(IdNumber)
Insurance = Social + Deduction_C + Deduction_F + Tax + Citizens
Supplied_B = Supplied_T - Insurance
Sht.Range(C_COL_TAX & Row).Value = Tax
Sht.Range(C_COL_INSURANCE & Row).Value = Insurance
Sht.Range(C_COL_SUPPLIED_B & Row).Value = Supplied_B
End If
Next Row
If HitCNT = 0 Then
Msg = C_ERR_MSG
Ret = False
Else
Ret = True
End If
Exit_Function:
If Not (Sht Is Nothing) Then Set Sht = Nothing
PostData = Ret
Exit Function
Err_Function:
Ret = False
Msg = Err.Description
Err.Clear
Resume Exit_Function
End Function
'転記対象データを取得する処理
Private Function AcquisitionData(ByVal SheetName As String, ByRef RetDic As Object, ByRef Msg As String) As Boolean
On Error GoTo Err_Function
Const C_ROW_ID As Long = 1
Const C_ROW_FLG As Long = 13
Const C_ROW_MONEY1 As Long = 53
Const C_ROW_MONEY2 As Long = 54
Const C_HIT_STR As String = "する"
Const C_ERR_MSG As String = "年調DATAからデータを取得できませんでした。"
Dim Ret As Boolean
Dim Sht As Excel.Worksheet
Dim Row As Long
Dim Col As Long
Dim IdNumber As String
Dim Restoration As Currency
Dim Lack As Currency
Set Sht = ThisWorkbook.Sheets(SheetName)
For Col = 2 To Sht.Cells(1, Sht.Columns.Count).End(xlToLeft).Column
If (Sht.Cells(C_ROW_FLG, Col).Value = C_HIT_STR) Then
IdNumber = Sht.Cells(C_ROW_ID, Col).Value
Restoration = Sht.Cells(C_ROW_MONEY1, Col).Value
Lack = Sht.Cells(C_ROW_MONEY2, Col).Value
If (0 < Restoration) Then
RetDic(IdNumber) = 0 - Restoration
Else
RetDic(IdNumber) = Lack
End If
End If
Next Col
If (RetDic.Count = 0) Then
Msg = C_ERR_MSG
Ret = False
Else
Ret = True
End If
Exit_Function:
If Not (Sht Is Nothing) Then Set Sht = Nothing
AcquisitionData = Ret
Exit Function
Err_Function:
Ret = False
Msg = Err.Description
Err.Clear
Resume Exit_Function
End Function
|
|
こたつねこ
- 10/12/17(金) 12:30 -
