| |
こんなのでは？
Option Explicit
Public Sub Sample()
'個数が10を超えたなら金額が10%割引
Const clngLimits As Long = 10
Dim i As Long
Dim j As Long
Dim lngRows As Long
Dim rngList As Range
Dim vntData() As Variant
Dim vntExce() As Variant
Dim lngExce() As Long
Dim vntResult() As Variant
Dim lngTmp As Long
Dim vntSum As Variant
Dim strProm As String
'例外集計をする拠点
vntExce = Array("東京")
'Listの先頭セル位置を基準とする（先頭列の列見出しのセル位置）
Set rngList = ActiveSheet.Range("A1")
With rngList
'行数の取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
'拠点、個数、金額列データを配列に取得
vntData = .Offset(1, 1).Resize(lngRows, 3).Value
End With
'累計数を保存する配列を確保
ReDim lngExce(UBound(vntExce))
'結果出力用配列を確保
ReDim vntResult(1 To lngRows, 1 To 3)
'Key列に就いて繰り返し
For i = 1 To lngRows
'小計を計算
vntResult(i, 1) = vntData(i, 2) * vntData(i, 3)
'例外集計か否かを確認
For j = 0 To UBound(vntExce)
If vntData(i, 1) = vntExce(j) Then
Exit For
End If
Next j
'例外集計で無いなら
If j > UBound(vntExce) Then
'小計を割引後小計に
vntResult(i, 2) = vntResult(i, 1)
Else
'累計個数がLimit以内の場合
If lngExce(j) + vntData(i, 2) <= clngLimits Then
'割引後小計を計算
vntResult(i, 2) = vntResult(i, 1)
Else
'10個以下の場合、割引無し分の個数を計算
lngTmp = 0
If clngLimits > lngExce(j) Then
lngTmp = clngLimits - lngExce(j)
End If
'割引無し分と割引分を計算
vntResult(i, 2) = lngTmp * vntData(i, 3) _
+ (vntData(i, 2) - lngTmp) * vntData(i, 3) * 0.9
End If
'累計個数を更新
lngExce(j) = lngExce(j) + vntData(i, 2)
End If
'累計金額を集計
vntSum = vntSum + vntResult(i, 2)
vntResult(i, 3) = vntSum
Next i
'結果を出力
With rngList.Offset(1, 4).Resize(lngRows, 3)
.ClearContents
.Value = vntResult
End With
strProm = "処理が完了しました"
Wayout:
Set rngList = Nothing
MsgBox strProm, vbInformation
End Sub
|
|
Hirofumi
- 10/9/25(土) 11:59 -
