I've got the following code...
In the range A1:A29 I have the following
In B1 and B2 I have 27.5 and 80, respectively.
B4 has Biweekly
Practically all of the declarations are Currency...
There are some custom functions folks here have assisted me with and are called within the above code...
If I want the code to fill in column B I have to run the macro more than once. I have spent days trying to figure this out and haven't been able to find my error. If I change something it seems to change the code enough where it doesn't work at all.
Can someone assist me please?
If you need more information, please feel free to ask.
-- g
Code:
Sub Calc_Fed_AnnualIncome()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set TheRange = Range("A1:B35").SpecialCells(xlCellTypeConstants, xlTextValues)
Wage = Range("B1")
Hours = Range("B2")
PPD = Range("B4")
P = ShowPayPeriod(PPD)
EnterPayPeriod
Dim pCell As Range
For Each pCell In TheRange
If pCell.Value = "P" Then
pCell.Offset(0, 1) = P
End If
Next pCell
Dim asalCell As Range
For Each asalCell In TheRange
If asalCell.Value = "Annual Salary" Then
asalCell.Offset(0, 1) = ASal
End If
Next asalCell
ASal = (Wage * Hours * P)
Dim iCell As Range
For Each iCell In TheRange
If iCell.Value = "I" Then
iCell.Offset(0, 1) = I
End If
Next iCell
'I = ((Wage * Hours * 52) / (P))
I = (ASal / P)
Dim fCell As Range
For Each fCell In TheRange
If fCell.Value = "F" Then
fCell.Offset(0, 1) = F
End If
Next fCell
Dim f2Cell As Range
For Each f2Cell In TheRange
If f2Cell.Value = "F2" Then
f2Cell.Offset(0, 1) = F2
End If
Next f2Cell
Dim u1Cell As Range
For Each u1Cell In TheRange
If u1Cell.Value = "U1" Then
u1Cell.Offset(0, 1) = U1
End If
Next u1Cell
Dim hdCell As Range
For Each hdCell In TheRange
If hdCell.Value = "HD" Then
hdCell.Offset(0, 1) = HD
End If
Next hdCell
Dim f1Cell As Range
For Each f1Cell In TheRange
If f1Cell.Value = "F1" Then
f1Cell.Offset(0, 1) = F1
End If
Next f1Cell
If A < 0 Then
T = L
Else: T = A
End If
Dim aCell As Range
For Each aCell In TheRange
If aCell.Value = "A" Then
aCell.Offset(0, 1) = A
End If
Next aCell
A = ((P * (I - F - F2 - U1)) - HD - F1)
Dim rCell As Range
For Each rCell In TheRange
If rCell.Value = "R" Then
rCell.Offset(0, 1) = R
End If
Next rCell
Range("B15").Select
ActiveCell.FormulaR1C1 = "=CaTaxRate(R[-1]C)"
Range("B15").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Paste
Application.CutCopyMode = False
R = CaTaxRate(A)
Dim arCell As Range
For Each arCell In TheRange
If arCell.Value = "AR" Then
arCell.Offset(0, 1) = AR
End If
Next arCell
AR = A * R
Dim kCell As Range
For Each kCell In TheRange
If kCell.Value = "K" Then
kCell.Offset(0, 1) = K
End If
Next kCell
K = CaTaxConstant(A)
Dim ftCell As Range
For Each ftCell In TheRange
If ftCell.Value = "FT" Then
ftCell.Offset(0, 1) = FT
End If
Next ftCell
FT = AR - K
'Next tcCell
Worksheets("TD1FED").Range("D19") = TC
Dim k1Cell As Range
For Each k1Cell In TheRange
If k1Cell.Value = "K1" Then
k1Cell.Offset(0, 1) = K1
End If
Next k1Cell
K1 = 0.15 * TC
Dim k2Cell As Range
For Each k2Cell In TheRange
If k2Cell.Value = "K2" Then
k2Cell.Offset(0, 1) = K2
End If
Next k2Cell
K2 = (0.15 * (Application.Min(P * C, 2217.6))) + (0.15 * (Application.Min(P * EI, 786.76)))
Dim k3Cell As Range
For Each k3Cell In TheRange
If k3Cell.Value = "K3" Then
k3Cell.Offset(0, 1) = K3
End If
Next k3Cell
Dim k4Cell As Range
For Each k4Cell In TheRange
If k4Cell.Value = "K4" Then
k4Cell.Offset(0, 1) = K4
End If
Next k4Cell
If (0.15 * A) < (0.15 * 1065) Then
K4 = (0.15 * A)
Else
K4 = (0.15 * 1065)
End If
Dim t3Cell As Range
Dim T3x1 As Currency
For Each t3Cell In TheRange
If t3Cell.Value = "T3" Then
t3Cell.Offset(0, 1) = T3
End If
Next t3Cell
T3x1 = K1 + K2 + K3 + K4
T3 = FT - T3x1
'CPP_Calc
CPPx = 3500
CPPd = 0.0495
Dim cppCell As Range
C = (I - (CPPx / P)) * CPPd
For Each cppCell In TheRange
If cppCell.Value = "CPP" Then
cppCell.Offset(0, 1) = C
End If
Next cppCell
'EmpIns
EIp = 0.0178
EI = I * EIp ' / P
Dim eiCell As Range
For Each eiCell In TheRange
If eiCell.Value = "EI" Then
eiCell.Offset(0, 1) = EI
End If
Next eiCell
Dim LCFCell As Range
For Each LCFCell In TheRange
If LCFCell.Value = "LCF" Then
LCFCell.Offset(0, 1) = LCF
End If
Next LCFCell
Dim W As Currency
Dim wCell As Range
For Each wCell In TheRange
If wCell.Value = "Withheld?" Then
wCell.Offset(0, 1) = W
End If
Next wCell
'W = 2000
If 0.15 * W < 750 Then
LCF = 0.15 * W
Else
LCF = 750
End If
Dim t1Cell As Range
For Each t1Cell In TheRange
If t1Cell.Value = "T1" Then
t1Cell.Offset(0, 1) = T1
End If
Next t1Cell
AR = A * R
T3 = A * R - (K + K1 + K2 + K3 + K4)
T1 = T3 - LCF
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End SubIn the range A1:A29 I have the following
Code:
Hourly Wage
Hours Worked
Wage Earned
Pay Period Description
Pay Period
Annual Salary
P
I
F
F2
U1
HD
F1
A
R
AR
K
FT
K1
K2
K3
K4
T3
Withheld?
LCF
T1
(A27 is blank)
CPP
EIIn B1 and B2 I have 27.5 and 80, respectively.
B4 has Biweekly
Practically all of the declarations are Currency...
Code:
Option Base 1
Option Explicit
Public A As Currency
Public C As Currency
Public CPPx As Currency
Public CPPd As Double
Public EI As Currency
Public EIp As Double
Public EIq As Double
Public F As Currency
Public F1 As Currency
Public F2 As Currency
Public F3 As Currency
Public F4 As Currency
Public QPIP As Double
Public HD As Currency
Public I As Currency
Public I1 As Currency
Public K As Currency
Public K1 As Currency
Public K2 As Currency
Public K3 As Currency
Public K4 As Currency
Public KP As Currency
Public K1P As Currency
Public K2P As Currency
Public K3P As Currency
Public K4P As Currency
Public L As Currency
Public LCF As Currency
Public LCP As Currency
Public P As Variant
Public R As Double
Public T As Currency
Public T1 As Currency
Public T2 As Currency
Public T3 As Currency
Public T3x1 As Currency
Public T4 As Currency
Public TC As Currency
Public TCP As Currency
Public U1 As Currency
Public V As Currency
Public V1 As Currency
Public V2 As Currency
Public YTD As Currency
Public Wage As Currency
Public Hours As Double
Public CPP As Currency
Public RA As Currency
Public FT As Currency
Public TheRange As Range
Public caTC As Currency
Public ASal As Currency
Public PPD As String
Public TD1FED As Currency
Public AR As Currency
Public W As CurrencyThere are some custom functions folks here have assisted me with and are called within the above code...
Code:
Function CaTaxRate(Rate) As Double
' Calculates Tax Rates
Select Case Rate
Case 0 To 41543.99: CaTaxRate = 1 * 0.15
Case 41544 To 83087.99: CaTaxRate = 1 * 0.22
Case 83088 To 128799.99: CaTaxRate = 1 * 0.26
Case Is >= 128800: CaTaxRate = 1 * 0.29
End Select
End Function
Function CaTaxConstant(Constant) As Double
' Calculates Tax Constants
Select Case Constant
Case 0 To 41543.99: CaTaxConstant = 1 * 0
Case 41544 To 83087.99: CaTaxConstant = 1 * 2908
Case 83088 To 128799.99: CaTaxConstant = 1 * 6232
Case Is >= 128800: CaTaxConstant = 1 * 10096
End Select
End Function
Function ShowPayPeriod(PayPeriod) As Integer
Select Case PayPeriod
Case "Daily": ShowPayPeriod = 240
Case "Weekly": ShowPayPeriod = 52
Case "Biweekly": ShowPayPeriod = 26
Case "Semi-monthly": ShowPayPeriod = 24
Case "Monthly": ShowPayPeriod = 12
Case "Other 10": ShowPayPeriod = 10
Case "Other 13": ShowPayPeriod = 13
Case "Other 22": ShowPayPeriod = 22
Case "Weekly 53": ShowPayPeriod = 53
Case "Biweekly 27": ShowPayPeriod = 27
End Select
End FunctionIf I want the code to fill in column B I have to run the macro more than once. I have spent days trying to figure this out and haven't been able to find my error. If I change something it seems to change the code enough where it doesn't work at all.
Can someone assist me please?
If you need more information, please feel free to ask.
-- g
