| |
ピボットテーブルの方が速いと思うけどこんなのも有るよ
Option Explicit
Public Sub Cross()
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 lngIndex() As Long
Dim strSheet As String
Dim lngWrite As Long
Dim vntItems As Variant
Dim strProm As String
'出力する列見出しを設定(営業部門名)
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
'ファイルの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
'データを配列に取得
vntData = .Offset(1).Resize(lngRow, 4).Value
wkbData.Close SaveChanges:=False
End With
Else
strProm = "データ元のWorkSheet「" & strSheet & "」が有りません"
wkbData.Close SaveChanges:=False
GoTo Wayout
End If
'データを整列
ReDim lngIndex(1 To UBound(vntData, 1))
For i = 1 To UBound(vntData, 1)
lngIndex(i) = i
Next i
For i = 1 To 3
ShellSort vntData, lngIndex, (i Mod 3) + 1
Next i
' Application.ScreenUpdating = False
'集計の初期値設定、配列の確保
lngRow = 0
ReDim vntResult(UBound(vntOffice) - 1, lngRow), vntItems(lngRow)
vntOffice(0) = vntData(lngIndex(1), 1)
vntItems(lngRow) = vntData(lngIndex(1), 3)
'集計
For i = 1 To UBound(lngIndex)
lngColumn = ColumnSearch(vntData(lngIndex(i), 2), vntOffice)
If lngColumn = -1 Then
strProm = "未登録の営業部門が有りますのでマクロを終了します"
GoTo Wayout
Else
'得意先が替わったら
If vntOffice(0) <> vntData(lngIndex(i), 1) Then
'結果を出力
DataWrite rngResult, lngWrite, vntResult, vntOffice, vntItems
'集計の初期値設定、配列の確保
lngRow = 0
ReDim vntResult(UBound(vntOffice) - 1, lngRow), vntItems(lngRow)
vntOffice(0) = vntData(lngIndex(i), 1)
vntItems(lngRow) = vntData(lngIndex(i), 3)
Else
'商品を探して、集計
lngRow = RowSearch(vntData(lngIndex(i), 3), vntItems)
If lngRow < 0 Then
lngRow = UBound(vntItems) + 1
ReDim Preserve vntResult(UBound(vntOffice) - 1, lngRow), vntItems(lngRow)
vntItems(lngRow) = vntData(lngIndex(i), 3)
End If
End If
vntResult(lngColumn, lngRow) _
= vntResult(lngColumn, lngRow) + vntData(lngIndex(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 Function RowSearch(ByVal vntKey As Variant, _
ByVal vntScope As Variant) As Long
Dim lngLow As Long
Dim lngHigh As Long
Dim lngMiddle As Long
lngLow = LBound(vntScope, 1)
lngHigh = UBound(vntScope, 1)
Do While lngLow <= lngHigh
lngMiddle = (lngLow + lngHigh) \ 2
Select Case vntScope(lngMiddle)
Case Is < vntKey
lngLow = lngMiddle + 1
Case Is > vntKey
lngHigh = lngMiddle - 1
Case Is = vntKey
lngLow = lngMiddle + 1
lngHigh = lngMiddle - 1
End Select
Loop
If lngLow = lngHigh + 2 Then
RowSearch = lngMiddle
Else
RowSearch = -1
End If
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
Private Sub ShellSort(vntList As Variant, _
lngIndex() As Long, _
Optional lngKey As Long = 1)
Dim i As Long
Dim j As Long
Dim lngGap As Long
Dim lngTmp As Long
Dim lngTop As Long
Dim lngEnd As Long
Dim lngOrder() As Long
lngTop = LBound(vntList, 1)
lngEnd = UBound(vntList, 1)
ReDim lngOrder(lngTop To lngEnd)
For i = lngTop To lngEnd
lngOrder(lngIndex(i)) = i
Next i
lngGap = 1
Do While lngGap < (lngEnd - lngTop + 1) \ 3
lngGap = 3 * lngGap + 1
Loop
Do Until lngGap = 0
For i = lngGap + lngTop To lngEnd
For j = i To lngGap + lngTop Step -lngGap
If vntList(lngIndex(j - lngGap), lngKey) _
> vntList(lngIndex(j), lngKey) Then
lngTmp = lngIndex(j - lngGap)
lngIndex(j - lngGap) = lngIndex(j)
lngIndex(j) = lngTmp
Else
If vntList(lngIndex(j - lngGap), lngKey) _
= vntList(lngIndex(j), lngKey) Then
If lngOrder(lngIndex(j - lngGap)) _
> lngOrder(lngIndex(j)) Then
lngTmp = lngIndex(j - lngGap)
lngIndex(j - lngGap) = lngIndex(j)
lngIndex(j) = lngTmp
End If
Else
Exit For
End If
End If
Next j
Next i
lngGap = lngGap \ 3
Loop
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
- 05/7/3(日) 11:30 -
