| |
以下を変更して下さい ★印追加、●印削除
vntCPosは、「部門」シートの出力列位置を指定しています、Array内の数値は、
'◆累計を転記するシートの基準位置を設定(指定位置の下の行に転記)
Set rngOther = Worksheets("部門").Cells(4, "C") '★追加
を基準とした、列Offsetで表わしています
売上がE列＝2、差益H列＝5、仕入L列＝9、在庫O列＝12
vntClearは、「部門」シートのデータをクリアする行位置を指定しています
vntRPosは、「部門」シートのデータ転記行位置を指定しています
Array内の30個の数値は、
'◆累計を転記するシートの基準位置を設定(指定位置の下の行に転記)
Set rngOther = Worksheets("部門").Cells(4, "C") '★追加
を基準とした、書き込む「係」の行Offsetで表わしています
例えばE5=1、E8=4、尚転記しない所は""で指定します
PS:
1、支店Aのグループ5が、書き込む欄が2つなのにデータは3つ転記する様に成っていますが？
2、質問では累計値なのに、「 - 07/6/14(木) 19:10 -」のコードでは、1日のデータですが？
Public Sub Main()
Dim vntKeyB1 As Variant
Dim rngOther As Range '★追加
Dim vntItem As Variant '★追加
Dim vntCPos As Variant '★追加
Dim vntRPos As Variant '★追加
Dim vntClear As Variant '★追加
Dim strProm As String
.
.
If Not IsDate(Left(vntKeyA2, 4) _
& "/" & Mid(vntKeyA2, 5, 2) _
& "/" & Right(vntKeyA2, 2)) Then
GoTo Wayout
End If
'◆「項目」列の抽出条件文字列を設定
vntItem = Array("売上", "差益", "仕入", "在庫") '★追加
'◆累計を転記する別シートの位置
'(上記、vntItemに対応する物とし、転記先基準からの列Offset値)
'売上がE列 差益H列 仕入L列 在庫O列
vntCPos = Array(2, 5, 9, 12) '★追加
'◆部門転記データのクリアする行位置
vntClear = Array(1, 4, 7, 10, 16, 19, 22, 25, 28, _
34, 37, 40, 43, 46, 56, 59, 62, 65, _
68, 71, 77, 80, 86, 89, 92) '★追加
'◆部門データの転記行位置を設定
'転記先C4セルを基準とし、基準からの行Offsetで指定
'例えばE5=1、E8=4、尚転記しない所は""で指定
Select Case vntKeyB1 '★追加
Case "本店" '★追加
vntRPos = Array(56, 59, 62, 77, 65, 89, 68, 71, 34, "", _
1, 37, "", 16, 19, 4, 22, 25, 40, 43, _
86, 46, 7, 10, 28, "", "", 80, "", 92) '★追加
Case "支店A" '★追加
vntRPos = Array(77, 80, "", "", 86, "", 83, 34, 37, "", _
16, 1, "", "", "", 19, 22, 56, 4, 59, _
40, 7, "", "", "", 25, "", 28, "", "") '★追加
Case "支店B" '★追加
vntRPos = Array("", "", "", "", "", "", "", "", "", 4, _
"", "", 1, "", "", "", "", "", "", "", _
"", "", "", "", "", "", 7, "", 16, "") '★追加
End Select '★追加
'◆累計を転記するシートの基準位置を設定(指定位置の下の行に転記)
Set rngOther = Worksheets("部門").Cells(4, "C") '★追加
'画面更新を停止
Application.ScreenUpdating = False
・
・
strProm = "抽出条件に一致するレコードが有りません"
If Not AddUp(rngList, rngResult, rngWork, vntKeyA1, _
vntKeyB1, clngColumns, clngItem, vntItem, rngOther, _
vntCPos, vntRPos, vntClear) Then '★変更、引数変更
GoTo Wayout
End If
If Not AddUp(rngList, rngResult.Offset(, 10), _
rngWork, vntKeyA2, vntKeyB1, clngColumns, _
clngItem, vntItem) Then '★変更、引数変更
GoTo Wayout
End If
strProm = "処理が完了しました"
・
・
'画面更新を再開
Application.ScreenUpdating = True
Set rngWork = Nothing
Set rngList = Nothing
Set rngResult = Nothing
Set rngOther = Nothing '★追加
MsgBox strProm, vbInformation
End Sub
'★引数追加
Private Function AddUp(rngList As Range, rngResult As Range, _
rngWork As Range, vntKeyA1 As Variant, _
vntKeyB1 As Variant, lngColumns As Long, _
lngItem As Long, _
vntItem As Variant, _
Optional rngOther As Range, _
Optional vntCPos As Variant, _
Optional vntRPos As Variant, _
Optional vntClear As Variant) As Boolean '★引数追加
'◆「1係」の列位置を指定(基準セル位置からの列Offset：基準がA1で「1係」がD列なら3)
Const clngBegin As Long = 3
Dim vntTop As Variant
' Dim vntItem As Variant '●削除
'●記述位置変更のため削除
'◆「項目」列の抽出条件文字列を設定
' vntItem = Array("売上", "差益", "仕入", "在庫") '●削除
'年度先頭の日付を取得
・
・
With rngResult
'出力結果の下に行列を入れ替え値のみPaste
.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
'転記するRangeが有り、且つ転記行位置が指定された場合
If (Not rngOther Is Nothing) _
And VarType(vntRPos) = vbArray + vbVariant Then '★追加
For i = UBound(vntCPos) To 0 Step -1 '★追加
'転記列位置の指定が有るなら
If vntCPos(i) <> "" Then '★追加
'転記先データを消去
For j = 0 To UBound(vntClear) '★追加
rngOther.Offset(vntClear(j), vntCPos(i)) = Empty '★追加
Next j '★追加
'データを転記
For j = 0 To UBound(vntRPos) '★追加
If vntRPos(j) <> "" Then '★追加
rngOther.Offset(vntRPos(j), vntCPos(i)).Value _
= .Offset(j + 2, lngRows + i).Value '★追加
End If '★追加
Next j '★追加
End If '★追加
Next i '★追加
End If '★追加
.Parent.Activate
.Select
End With
End Function
|
|
Hirofumi
- 07/6/15(金) 19:57 -
