| |
▼Hirofumi さん
お忙しいのにご足労かけてすいません
只今実行中なのですが、1係の06年実績と07年目標が表示されず 2係の06年実績と07年目標の欄にずれて表示されるのですが？ご指示どおりコードはcopyしたのですが
Public Sub Sample2()
Const clngColumns As Long = 33
Const clngBegin As Long = 3
Const clngDate As Long = 0
Const clngStores As Long = 1
Const clngItem As Long = 2
'出力シートの各緒言
Const cstrResult As String = "A3"
Const clngNo As Long = 3
Const clngBlock As Long = 163
Dim i As Long, j As Long, k As Long, l As Long
Dim lngRows As Long
Dim rngList As Range
Dim rngResult() As Range
Dim rngWork As Range
Dim vntResult As Variant
Dim vntStores As Variant
Dim vntData As Variant
Dim vntTitle(1) As Variant
Dim vntItems As Variant
Dim lngMonth As Long
Dim lngPitch As Long
Dim vntYear As Long
Dim vntCriteria(1) As Variant
Dim vntOffset As Variant
Dim lngCalc As Long
Dim strProm As String
lngCalc = Application.Calculation
Set rngList = Worksheets("List1").Cells(1, "A")
vntTitle(0) = Array("年実績", "前年比", _
"達成率", "年実績", "年目標")
vntTitle(1) = Array("年差益", "前年比", _
"達成率", "年差益", "年目標")
lngPitch = UBound(vntTitle(0)) + 1
vntCriteria(0) = Array("売上", "売上", "売上目標")
vntCriteria(1) = Array("差益", "差益", "差益目標")
'出力行位置を設定
vntOffset = Array(0, 3, 4)
With rngList
lngRows = .CurrentRegion.Rows.Count - 1
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
vntData = .Offset(1, clngStores).Resize(lngRows + 1).Value
ReDim vntStores(0)
vntStores(0) = vntData(1, 1)
For i = 2 To lngRows
For j = 0 To UBound(vntStores)
If vntData(i, 1) = vntStores(j) Then
Exit For
End If
Next j
If j > UBound(vntStores) Then
'無重複で取得している配列に店舗名を追加
ReDim Preserve vntStores(UBound(vntStores) + 1)
vntStores(UBound(vntStores)) = vntData(i, 1)
End If
Next i
vntItems = .Offset(, clngBegin) _
.Resize(, clngColumns - clngBegin)
'最大の日付を取得
vntYear = Application.Max(.Offset(1, _
clngDate).Resize(lngRows))
'★「20070401」形式の場合は下記を活かす
vntYear = DateValue(Left(vntYear, 4) & "/" _
& Mid(vntYear, 5, 2) & "/" & Right(vntYear, 2))
If Month(vntYear) <= 3 Then
vntYear = Year(vntYear) - 1
Else
vntYear = Year(vntYear)
End If
End With
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
ReDim rngResult(UBound(vntStores))
For i = 0 To UBound(vntStores)
If SheetExists(vntStores(i)) Then
Set rngResult(i) _
= Worksheets(vntStores(i)).Range(cstrResult)
With rngResult(i).Parent
.Cells.ClearContents
.Activate
End With
Else
Set rngResult(i) = Worksheets.Add( _
After:=ActiveSheet).Range(cstrResult)
rngResult(i).Parent.Name = vntStores(i)
End If
Next i
With Worksheets
Set rngWork = .Add(After:=.Item(.Count)).Cells(1, "A")
End With
With rngWork
rngList.Resize(, clngColumns).Copy Destination:=.Item(1)
With .Offset(, clngColumns)
'AdvancedFilter条件範囲の列見出しの出力
.Offset(, 1).Value = rngList.Offset(, clngStores).Value
.Offset(, 2).Value = rngList.Offset(, clngItem).Value
.Offset(, 3).Resize(, 2).Value _
= rngList.Offset(, clngDate).Value
End With
For i = 0 To UBound(vntStores)
.Offset(1, clngColumns + 1).Value _
= "=" & """=" & vntStores(i) & """"
For j = 0 To 1
ReDim vntResult(1 To (clngColumns _
- clngBegin) * lngPitch, 1 To 12)
For k = 0 To 2
.Offset(1, clngColumns + 2).Value _
= "=" & """=" & vntCriteria(j)(k) & """"
If k = 0 Or k = 2 Then
'★月の値を代入(「20070401」形式の場合)
.Offset(1, clngColumns + 3).Value = "=" & """>=" _
& Format(DateSerial(vntYear, 4, 1), "yyyymmdd") & """"
.Offset(1, clngColumns + 4).Value = "=" & """<=" _
& Format(DateSerial(vntYear + 1, 3, 31), "yyyymmdd") & """"
Else
'★月の値を代入(「20070401」形式の場合)
.Offset(1, clngColumns + 3).Value = "=" & """>=" _
& Format(DateSerial(vntYear - 1, 4, 1), "yyyymmdd") & """"
.Offset(1, clngColumns + 4).Value = "=" & """<=" _
& Format(DateSerial(vntYear, 3, 31), "yyyymmdd") & """"
End If
DoFilter rngList.CurrentRegion, .Offset(, _
clngColumns + 1).Resize(2, 4), .Resize(, clngColumns)
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
If lngRows >= 1 Then
.Offset(1).Resize(lngRows, clngColumns).Sort _
Key1:=.Offset(1), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
vntData = .Offset(1).Resize(lngRows, clngColumns).Value
'★月の値を取得(「20070401」形式の場合)
lngMonth = Val(Mid(vntData(1, clngDate + 1), 5, 2))
DataCalc vntResult, lngMonth, vntData, 1, _
clngColumns, lngPitch, clngBegin, vntOffset(k)
For l = 2 To lngRows
'★月が違った場合(「20070401」形式の場合)
If Val(Mid(vntData(l, clngDate + 1), 5, 2)) <> lngMonth Then
'★月の値を取得(「20070401」形式の場合)
lngMonth = Val(Mid(vntData(l, clngDate + 1), 5, 2))
End If
DataCalc vntResult, lngMonth, vntData, l, _
clngColumns, lngPitch, clngBegin, vntOffset(k)
Next l
End If
Next k
With rngResult(i)
.Offset(clngNo + clngBlock * j, 2).Resize(UBound(vntResult, 1), _
UBound(vntResult, 2)).Value = vntResult
OutputTerminate .Offset(clngBlock * j), vntItems, _
vntYear, vntTitle(j), clngNo
End With
Next j
Next i
rngResult(0).Parent.Activate
End With
strProm = "処理が完了しました"
Wayout:
If Not rngWork Is Nothing Then
Application.DisplayAlerts = False
rngWork.Parent.Delete
Application.DisplayAlerts = True
End If
With Application
.Calculation = lngCalc
.Calculate
.ScreenUpdating = True
End With
Set rngWork = Nothing
Set rngList = Nothing
For i = 0 To UBound(rngResult)
Set rngResult(i) = Nothing
Next i
MsgBox strProm, vbInformation
End Sub
Private Sub DataCalc(vntResult As Variant, lngMonth As Long, _
vntData As Variant, lngPos As Long, _
lngColumns As Long, lngPitch As Long, _
lngBegin As Long, vntOffset As Variant)
Dim i As Long
Dim lngColumn As Long
Dim lngRow As Long
lngColumn = (lngMonth + 8) Mod 12 + 1
For i = 1 To lngColumns - lngBegin
lngRow = (i - 1) * lngPitch + 1 + vntOffset
vntResult(lngRow, lngColumn) _
= vntResult(lngRow, lngColumn) + vntData(lngPos, lngBegin + i)
Next i
End Sub
どこかまた私のミスでしょうかご点検お願いできますか
(20070401形式にしました)
|
|
hiro
- 07/5/22(火) 19:13 -
