Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

14600 / 76734

←次へ　｜　前へ→


	【67623】Re:様式の異なるシート間での値の抽出と転記について

八家九僧陀 - 10/12/18(土) 23:52 -


	引用なし

	パスワード

▼こたつねこさん：
お世話をお掛けして、ありがとうございます。
そっくりそのままコピペして実行してみたのですが、
Const C_ERR_MSG　　　　 As String = "該当するデータがありませんでした。"
の"該当するデータがありませんでした。"とすぐに表示され終了します。
わたしにとっては、とても難解なコードで、自力で改善する能力もありません。
引き続きご教示をお願いします。

>八家九僧陀さん
>はじめまして、こたつねこと申します。
>すでに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

1 hits

▼

【67583】様式の異なるシート間での値の抽出と転記について 八家九僧陀 10/12/16(木) 12:48