Excel VBA質問箱 IV

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

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


14620 / 76734 ←次へ | 前へ→

【67603】Re:様式の異なるシート間での値の抽出と転記について
回答  こたつねこ  - 10/12/17(金) 12:30 -

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

0 hits

【67583】様式の異なるシート間での値の抽出と転記について 八家九僧陀 10/12/16(木) 12:48 質問
【67588】Re:様式の異なるシート間での値の抽出と転... UO3 10/12/16(木) 21:58 回答
【67589】Re:様式の異なるシート間での値の抽出と転... UO3 10/12/16(木) 22:21 発言
【67591】Re:様式の異なるシート間での値の抽出と転... 八家九僧陀 10/12/17(金) 2:10 お礼
【67599】Re:様式の異なるシート間での値の抽出と転... UO3 10/12/17(金) 10:44 回答
【67600】Re:様式の異なるシート間での値の抽出と転... UO3 10/12/17(金) 11:33 回答
【67622】Re:様式の異なるシート間での値の抽出と転... 八家九僧陀 10/12/18(土) 23:48 発言
【67624】Re:様式の異なるシート間での値の抽出と転... UO3 10/12/19(日) 7:44 発言
【67625】Re:様式の異なるシート間での値の抽出と転... UO3 10/12/19(日) 8:33 発言
【67628】Re:様式の異なるシート間での値の抽出と転... UO3 10/12/19(日) 9:34 発言
【67629】Re:様式の異なるシート間での値の抽出と転... UO3 10/12/19(日) 15:25 回答
【67632】Re:様式の異なるシート間での値の抽出と転... 八家九僧陀 10/12/20(月) 0:09 お礼
【67633】Re:様式の異なるシート間での値の抽出と転... UO3 10/12/20(月) 6:46 発言
【67647】Re:様式の異なるシート間での値の抽出と転... 八家九僧陀 10/12/20(月) 22:54 発言
【67660】Re:様式の異なるシート間での値の抽出と転... UO3 10/12/21(火) 18:22 発言
【67670】Re:様式の異なるシート間での値の抽出と転... 八家九僧陀 10/12/22(水) 17:44 発言
【67671】Re:様式の異なるシート間での値の抽出と転... UO3 10/12/22(水) 18:14 発言
【67674】Re:様式の異なるシート間での値の抽出と転... 八家九僧陀 10/12/23(木) 21:53 お礼
【67603】Re:様式の異なるシート間での値の抽出と転... こたつねこ 10/12/17(金) 12:30 回答
【67623】Re:様式の異なるシート間での値の抽出と転... 八家九僧陀 10/12/18(土) 23:52 発言

14620 / 76734 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free