| |
考え過ぎで、複雑にし過ぎました
もっとコードが簡単に速くなります
Option Explicit
Public Sub Cross2()
Dim i As Long
Dim lngRow As Long
Dim lngColumn As Long
Dim vntOffice As Variant
Dim wkbData As Workbook
Dim wksData As Worksheet
Dim vntData As Variant
Dim wksResult As Worksheet
Dim rngResult As Range
Dim vntResult As Variant
Dim strSheet As String
Dim lngWrite As Long
Dim vntItems As Variant
Dim strProm As String
Dim vntFileName As Variant
'出力する列見出しを設定(営業部門名)
vntOffice = Array("", "京都", "大阪", "神戸", "合計")
'シート名を取得
strSheet = InputBox("処理するシートを「2005.6」の形で入力して下さい ", _
"シート名入力", Format(Date, "yyyy.m"))
If strSheet = "" Then
strProm = "マクロがキャンセルされました"
GoTo Wayout
End If
'シートの存在確認
If SheetsCheck(strSheet, wksResult, ActiveWorkbook) Then
Set rngResult = wksResult.Cells(2, "B")
Else
strProm = "出力先のWorkSheet「" & strSheet & "」が有りません"
GoTo Wayout
End If
' Application.ScreenUpdating = False
'ファイルのOpen
Set wkbData = Workbooks.Open("C:\Documents and Settings\質問\db.xls")
'シートの存在確認、データの取得
If SheetsCheck(strSheet, wksData, wkbData) Then
With wksData.Cells(1, "A")
'データ行数の取得
lngRow = .Offset(65536 - .Row).End(xlUp).Row - .Row
If lngRow <= 0 Then
strProm = "データ元のデータが有りません"
wkbData.Close SaveChanges:=False
GoTo Wayout
End If
With .Offset(1).Resize(lngRow, 4)
.Sort Key1:=.Item(1, 1), Order1:=xlAscending, _
Key2:=.Item(1, 3), Order2:=xlAscending, _
Key3:=.Item(1, 2), Order3:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
'データを配列に取得
vntData = .Value
End With
wkbData.Close SaveChanges:=False
End With
Else
strProm = "データ元のWorkSheet「" & strSheet & "」が有りません"
wkbData.Close SaveChanges:=False
GoTo Wayout
End If
'集計の初期値設定、配列の確保
lngRow = 0
ReDim vntResult(UBound(vntOffice) - 1, lngRow), vntItems(lngRow)
vntOffice(0) = vntData(1, 1)
vntItems(lngRow) = vntData(1, 3)
'集計
For i = 1 To UBound(vntData, 1)
lngColumn = ColumnSearch(vntData(i, 2), vntOffice)
If lngColumn = -1 Then
strProm = "未登録の営業部門が有りますのでマクロを終了します"
GoTo Wayout
Else
'得意先が替わったら
If vntOffice(0) <> vntData(i, 1) Then
'結果を出力
DataWrite rngResult, lngWrite, vntResult, vntOffice, vntItems
'集計の初期値設定、配列の確保
lngRow = 0
ReDim vntResult(UBound(vntOffice) - 1, lngRow), vntItems(lngRow)
vntOffice(0) = vntData(i, 1)
vntItems(lngRow) = vntData(i, 3)
Else
'商品を探して、集計
If vntItems(lngRow) <> vntData(i, 3) Then
lngRow = lngRow + 1
ReDim Preserve vntResult(UBound(vntOffice) - 1, lngRow), vntItems(lngRow)
vntItems(lngRow) = vntData(i, 3)
End If
End If
vntResult(lngColumn, lngRow) _
= vntResult(lngColumn, lngRow) + vntData(i, 4)
End If
Next i
DataWrite rngResult, lngWrite, vntResult, vntOffice, vntItems
strProm = "処理が完了しました"
Wayout:
' Application.ScreenUpdating = True
Set wkbData = Nothing
Set wksData = Nothing
Set wksResult = Nothing
Set rngResult = Nothing
Beep
MsgBox strProm
End Sub
Private Function SheetsCheck(strMark As String, _
wksMark As Worksheet, _
wkbBook As Workbook) As Boolean
With wkbBook
For Each wksMark In .Worksheets
If StrComp(wksMark.Name, strMark) = 0 Then
SheetsCheck = True
Exit Function
End If
Next wksMark
End With
End Function
Private Function ColumnSearch(vntKey As Variant, _
vntList As Variant) As Long
Dim i As Long
ColumnSearch = -1
For i = 1 To UBound(vntList)
If vntList(i) = vntKey Then
ColumnSearch = i - 1
Exit Function
End If
Next i
End Function
Private Sub DataWrite(rngOutput As Range, _
lngWrite As Long, _
vntResult As Variant, _
vntOffice As Variant, _
vntItems As Variant)
Dim i As Long
Dim j As Long
Dim lngRow As Long
Dim lngColumn As Long
lngRow = UBound(vntResult, 2) + 1
lngColumn = UBound(vntOffice) - 1
ReDim Preserve vntResult(lngColumn, lngRow)
For i = 0 To lngRow - 1
For j = 0 To lngColumn - 1
vntResult(lngColumn, i) = vntResult(lngColumn, i) + vntResult(j, i)
vntResult(j, lngRow) = vntResult(j, lngRow) + vntResult(j, i)
Next j
Next i
lngColumn = UBound(vntItems) + 1
ReDim Preserve vntItems(lngColumn)
vntItems(lngColumn) = "合計"
With rngOutput.Offset(lngWrite)
.Offset(, -1).Resize(, UBound(vntOffice) + 1).Value = vntOffice
.Offset(1, -1).Resize(UBound(vntResult, 2) + 1).Value _
= Application.Transpose(vntItems)
.Offset(1).Resize(UBound(vntResult, 2) + 1, _
UBound(vntOffice)).Value _
= Application.Transpose(vntResult)
End With
lngWrite = lngWrite + UBound(vntItems, 1) + 1 + 2
End Sub
|
|
Hirofumi
- 05/7/3(日) 17:59 -
