| |
Dictionaryだとこんなかな？
Option Explicit
Public Sub Sample_2()
'"支給台帳"のデータ列数（A列〜CR列）
Const clngColumns As Long = 96
'"社員ID"の有る列(C列のA列からの列Offset A列を0列として勘定する)
Const clngGroup As Long = 2
Dim i As Long
Dim j As Long
Dim k As Long
Dim lngRows As Long
Dim rngList As Range
Dim rngResult As Range
Dim vntPost As Variant
Dim vntData() As Variant
Dim vntResult() As Variant
Dim vntPos As Variant
Dim dicIndex As Object
Dim strProm As String
'"支給台帳"の先頭セル位置を基準とする（先頭列の列見出しのセル位置）
Set rngList = Worksheets("支給台帳").Range("A1")
'"年調データ"の先頭セル位置を基準とする（先頭列の列見出しのセル位置）
Set rngResult = Worksheets("年調データ").Range("A1")
'"支給台帳"の社員ID、氏名、課税所得額、社会保険控除額、源泉徴収税額の
'列位置をA列を1列として、列挙する
vntPost = Array(3, 4, 78, 92, 93)
'Dictionaryオブジェクトを取得
Set dicIndex = CreateObject("Scripting.Dictionary")
'"年調データ"に就いて
With rngResult
'行数の取得
lngRows = .Offset(Rows.Count - .Row, clngGroup).End(xlUp).Row - .Row
'データが有ればクリア
If lngRows > 0 Then
.Offset(1).Resize(lngRows, UBound(vntPost) + 1).ClearContents
End If
End With
'"支給台帳"に就いて
With rngList
'行数の取得
lngRows = .Offset(Rows.Count - .Row, clngGroup).End(xlUp).Row - .Row
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
End With
'出力用配列を確保（12か月分）
ReDim vntResult(1 To -Int(-lngRows / 12), UBound(vntPost))
'1行目〜最終行まで繰り返し
For i = 1 To lngRows
'"支給台帳"の1行分を配列として取得
vntData = rngList.Offset(i).Resize(, clngColumns).Value
vntPos = dicIndex.Item(CStr(vntData(1, clngGroup + 1)))
'社員IDが違った場合
If Not IsEmpty(vntPos) Then
'出力用配列に課税所得額、社会保険控除額、源泉徴収税額を加算
For j = 2 To UBound(vntPost)
vntResult(vntPos, j) = vntResult(vntPos, j) + vntData(1, vntPost(j))
Next j
Else
k = k + 1
dicIndex.Item(CStr(vntData(1, clngGroup + 1))) = k
'出力用配列に転記
For j = 0 To UBound(vntPost)
vntResult(k, j) = vntData(1, vntPost(j))
Next j
End If
Next i
'結果を出力
rngResult.Offset(1).Resize(k, UBound(vntPost) + 1).Value = vntResult
strProm = "処理が完了しました"
Wayout:
Set dicIndex = Nothing
Set rngList = Nothing
Set rngResult = Nothing
MsgBox strProm, vbInformation
End Sub
|
|
Hirofumi
- 10/12/9(木) 9:29 -
