Option Explicit
Sub AddDiscount()
Dim wbItem As Workbook
Dim wsInput As Worksheet
Dim rData As Range, rData1 As Range, rLast As Range, rTemp As Range
Dim iRow As Long, iItem As Long, i As Long
Dim dDiscount As Double
Dim vItems As Variant, vPrices As Variant
Application.ScreenUpdating = False
'get normal prices
Workbooks.Add "C:\FlexibakeConversions\Flexitem prices.xlsx" ' <<<<<<<<<<<<< change WB path
Set wbItem = ActiveWorkbook
Set rTemp = wbItem.Worksheets("Sheet1").Range("C1")
Set rTemp = Range(rTemp, rTemp.End(xlDown))
vItems = Application.WorksheetFunction.Transpose(rTemp)
Set rTemp = wbItem.Worksheets("Sheet1").Range("E1")
Set rTemp = Range(rTemp, rTemp.End(xlDown))
vPrices = Application.WorksheetFunction.Transpose(rTemp)
wbItem.Close False
'set data
Set wsInput = Worksheets("Input") ' <<<<< Change WS name
Set rLast = wsInput.Cells(1, wsInput.Columns.Count).End(xlToLeft)
Set rData = Range(wsInput.Cells(1, 1), rLast).EntireColumn
Set rData = Intersect(rData, wsInput.Cells(1, 1).CurrentRegion.EntireRow)
Set rData1 = rData.Cells(2, 1).Resize(rData.Rows.Count - 1, rData.Columns.Count)
'add Normal Prices
With wsInput
.Cells(1, 8).Value = "Discount Price"
.Cells(1, 9).Value = "line class"
For iRow = 2 To rData.Rows.Count
iItem = 0
On Error Resume Next
iItem = Application.WorksheetFunction.Match(.Cells(iRow, 4).Value, vItems, 0)
On Error GoTo 0
If iItem > 0 Then .Cells(iRow, 7).Value = vPrices(iItem)
Next iRow
End With
With wsInput
For i = 2 To ActiveSheet.Cells(1, 1).CurrentRegion.Rows.Count
If ActiveSheet.Cells(i, 6).Value > ActiveSheet.Cells(i, 7).Value Then
ActiveSheet.Cells(i, 6).Value = ActiveSheet.Cells(i, 7).Value
End If
Next i
End With
'sort by invoice data and invoice number
With wsInput.Sort
.SortFields.Clear
.SortFields.Add Key:=rData1.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add2 Key:=rData1.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rData
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'go up and add "20 Sales & Discount" to col D after invoice change
With wsInput
For iRow = rData.Rows.Count To 2 Step -1
If .Cells(iRow + 1, 2).Value <> .Cells(iRow, 2).Value Then
.Rows(iRow + 1).Insert
.Cells(iRow + 1, 4).Value = "20 Sales & Discount"
.Cells(iRow + 1, 9).Value = "2.5 Sales Promotional Discount"
End If
Next iRow
End With
'go down and calc discount and fill in data
dDiscount = 0#
With wsInput
Set rData = .Cells(1, 1).CurrentRegion
For iRow = 2 To rData.Rows.Count
If Len(.Cells(iRow, 1).Value) > 0 Then
dDiscount = dDiscount + .Cells(iRow, 5).Value * (.Cells(iRow, 7).Value - .Cells(iRow, 6).Value)
Else
.Cells(iRow, 1).Value = .Cells(iRow - 1, 1).Value
.Cells(iRow, 2).Value = .Cells(iRow - 1, 2).Value
.Cells(iRow, 3).Value = .Cells(iRow - 1, 3).Value
.Cells(iRow, 8).Value = dDiscount
dDiscount = 0#
End If
Next iRow
End With
'cleanup
Application.ScreenUpdating = True
End Sub