Option Explicit
Const colAcct As Long = 4
Const colLoc As Long = 5
Const colDebit As Long = 9
Const colCredit As Long = 10
Sub FuncAllocJnl()
Dim wsJournal As Worksheet, wsAPercent As Worksheet
Dim wsVolume As Worksheet, wsAssess As Worksheet, wsSPS As Worksheet
Dim LastCol As Long, x As Long, i As Long, n As Long, q As Long
Dim LastRow As Long, rowJournal As Long
Dim rng As Range, c As Range
Dim rVolume As Range, rAssess As Range, rSPS As Range
Dim colVolume As Long, colAssess As Long, colSPS As Long
Dim VolRowTotal As Long, AssRowTotal As Long, SPSRowTotal As Long
Dim RowVolume As Long, RowAssess As Long, RowSPS As Long
Dim VolRowHeader As Long, AssRowHeader As Long, SPSRowHeader As Long
Dim VolRowStart As Long, AssRowStart As Long, SPSRowStart As Long
Set wsJournal = Worksheets("Journal")
Set wsAPercent = Worksheets("Allocation %")
Set wsVolume = Worksheets("Volume Allocation")
Set wsAssess = Worksheets("Assess Allocation")
Set wsSPS = Worksheets("SPS Allocation")
'Preparing the sheet by removing previous month data and resetting journal header for current month
Application.ScreenUpdating = False
With wsJournal
.Rows("7:" & Rows.Count).ClearContents
.Rows("7:" & Rows.Count).ClearFormats
.Cells(4, 3).Value = Date
.Cells(4, 5) = Format(Date, "yyyy")
.Cells(4, 6).NumberFormat = "mm"
.Cells(4, 8).Value = "Functional Allocations" & " " & MonthName(Month(Date)) & " " & Year(Date)
End With
'FOR VOLUME ALLOCATIONS
'Copy all location codes for which allocation % is not zero
With wsAPercent
Set rng = ThisWorkbook.Worksheets("Allocation %").Range("B6:D" & ThisWorkbook.Worksheets("Allocation %").[B65536].End(3).Offset(-1, -1).Row)
rng.AutoFilter 3, ">0", xlAnd, "<>"
Application.Index(rng.Offset(1), , 1).Copy ThisWorkbook.Worksheets("Journal").[E8]
rng.AutoFilter
End With
'Copy all BS codes for which allocation % is not zero
With wsAPercent
Set rng = ThisWorkbook.Worksheets("Allocation %").Range("B6:D" & ThisWorkbook.Worksheets("Allocation %").[B65536].End(3).Offset(-1, -1).Row)
rng.AutoFilter 3, ">0", xlAnd, "<>"
Application.Index(rng.Offset(1), , 2).Copy ThisWorkbook.Worksheets("Journal").[F8]
rng.AutoFilter
End With
'Correct formatting of rows copied in 2 steps above
With wsJournal
Range("E8:F" & Cells(Rows.Count, "F").End(xlUp).Row).Select
With Selection
.ClearFormats
.HorizontalAlignment = xlLeft
.Font.Name = "Arial"
.Font.Size = 9
End With
End With
'Copy all the nominal codes that have to be posted, transpose the layout, duplicate for the number of location codes needed
With wsVolume
LastCol = .Cells(7, .Columns.Count).End(xlToLeft).Offset(, -1).Column
x = 7
For i = 5 To LastCol
If .Cells(7, i).Value <> 0 Then
Sheets("Journal").Cells(x, "D").Value = .Cells(8, i).Value
x = x + Sheets("Journal").Cells(2, 16).Value
End If
Next i
End With
'Duplicate nominals to be posted for every location code line and insert location 050 at first line
With wsJournal
.Cells(7, 5).Value = "'50"
.Cells(7, 6).Value = "'015"
For Each c In Range("D7:D" & Cells(Rows.Count, "D").End(xlUp).Row).SpecialCells(2)
c.Offset(1).Resize(17).Value = c.Value
Next c
End With
'Copy all the VOLUME debits and credit, with correct transposition for journal
Set rVolume = wsVolume.Cells(8, 5).CurrentRegion
VolRowTotal = rVolume.Rows(1).Row
VolRowHeader = rVolume.Rows(2).Row
VolRowStart = rVolume.Rows(3).Row
rowJournal = 1
With wsVolume
For colVolume = 5 To rVolume.Columns.Count
Select Case .Cells(VolRowTotal, colVolume).Value
Case Is = 0
GoTo NextCol
Case Is > 0
wsJournal.Cells(rowJournal, colCredit).Value = Round(.Cells(VolRowTotal, colVolume).Value, 2)
Case Is < 0
wsJournal.Cells(rowJournal, colDebit).Value = Round(-.Cells(VolRowTotal, colVolume).Value, 2)
End Select
wsJournal.Cells(rowJournal, colAcct).Value = .Cells(VolRowHeader, colVolume).Value
rowJournal = rowJournal + 1
For RowVolume = VolRowStart To rVolume.Cells(1, 1).Row + rVolume.Rows.Count - 1
wsJournal.Cells(rowJournal, colAcct).Value = .Cells(VolRowHeader, colVolume).Value
wsJournal.Cells(rowJournal, colLoc).Value = .Cells(RowVolume, 2).Value
Select Case .Cells(RowVolume, colVolume).Value
Case Is = 0
GoTo NextRow
Case Is < 0
wsJournal.Cells(rowJournal, colCredit).Value = Round(-.Cells(RowVolume, colVolume).Value, 2)
Case Is > 0
wsJournal.Cells(rowJournal, colDebit).Value = Round(.Cells(RowVolume, colVolume).Value, 2)
End Select
rowJournal = rowJournal + 1
NextRow:
Next RowVolume
NextCol:
Next colVolume
End With
'Copy location codes to be posted for all nominal code lines
' With ThisWorkbook.Worksheets("Journal")
' Range("E7:E" & Range("E" & Rows.Count).End(xlUp).Row).AutoFill Destination:=Range("E7:E" & Range("D" & Rows.Count).End(xlUp).Row), xlFillValues
' Range("F7:F" & Range("F" & Rows.Count).End(xlUp).Row).AutoFill Destination:=Range("F7:F" & Range("D" & Rows.Count).End(xlUp).Row), xlFillValues
' End With
'Assign values to columns A, B, H & copy down for all rows in journal
With wsJournal
.Cells(7, 1).Value = "Post"
.Cells(7, 2).Value = "1"
.Cells(7, 8).Value = .Cells(4, 8).Value
Range("A7").AutoFill .Range("A7:A" & .Cells(.Rows.Count, "D").End(xlUp).Row), xlFillCopy
Range("B7").AutoFill .Range("B7:B" & .Cells(.Rows.Count, "D").End(xlUp).Row), xlFillCopy
Range("H7").AutoFill .Range("H7:H" & .Cells(.Rows.Count, "D").End(xlUp).Row), xlFillCopy
End With
Application.ScreenUpdating = True
End Sub
Reply With Quote
Originally Posted by Paul_Hossler
