#1
|
|||
|
|||
Macros problem with XP
For SEVERAL years our accounting department has been using macros set up in
Excel to import data into our Peachtree Accounting software. (I did not set these macros up, nor know how to!) We recently got new computers that have Windows XP Professional. When we try to run the Macros the following error comes up: "Remote Data not accessible. Start application 'PEACHW.EXE'?" Even when you click yes, the following message comes up: "The Peachtree accounting program must be running in the background before running this function. Start Peachtree then try again." I have tried having Peachtree open, closed, just about anything I can think of. I don't want to change the macros because they are working just fine for our Windows 98 machines. Please help! Let me know if you need additional information. Even our IT consultant is currently stumped. ~Gretchen |
#2
|
|||
|
|||
RE: Macros problem with XP
It would help if you could post the macro code. The most important part is
where it is trying to do the import and it obviously is checking to see if Peachtree is running. The solution will depend on what method the macro uses to see if Peachtree is open. The error messages you note must be "hard coded" in the macro code, so the code that surrounds those messages would be key to understanding what is happening. |
#3
|
|||
|
|||
RE: Macros problem with XP
It is too long for one posting so I am seperating it into three postings.
Here is the first part: '************************************************* ************************* '** FILE: PAYROLL.XLS '** PURPOSE: Generate Invoice & Payroll transactions via DDE into Peachtree. '** AUTHOR: Conrad R. Meitl, KHS '** CREATED: December 08, 1994 '** REVISED: DATE SE DESCRIPTION '** 12/09/94 KHS/CM Added Edit button to Payroll_Entry sheet. '** 12/11/94 KHS/CM Eliminated screen update during execution. '** 12/13/94 KHS/CM Added Add button to Payroll_Entry sheet. '** 12/15/94 KHS/CM Added status display window during processing. '** 01/25/95 KHS/CM Updated tax tables. '** 07/18/95 LM Changed SUI to 0. '** 12/28/95 CRM Updated 1996 tax tables. '** 12/14/96 LM Changed departments - adding 1,2, or 3 for offices. '** 12/26/96 CRM/LM Updated 1997 tax tables. '** 12/23/97 CRM/LM Updated 1998 tax tables. '** 02/18/98 CRM/LM Always update customer and employee list. '** 01/04/99 CRM/LM/TW Updated 1999 tax tables. '** 04/23/99 CRM Widen year fields to 4 places. '** 12/29/99 LM/TW/CRM Updated 2000 tax tables. '** 12/28/00 LM/TW Updated 2001 tax tables. '** 07/02/01 LM Updated 2001 tax tables for FIT only. '** 12/31/01 LM/TW Updated 2002 tax tables. '** 12/30/02 TW Updated 2003 tax tables. '** 06/19/03 VS Removed "SortbyEmp" procedure; removed "SortbyEmp" in UpdatePayrollSummary Procedure. '** 09/10/03 TW Updated tax tables '** NOTES: This program requires a Peachtree password with access to employee, '** customer, payroll and invoice screens. '** Some worksheet items are hidden to improve appearance. These items '** can be displayed for maintenance by running the "SetDevelopmentEnv" '** macro. They can be rehidden with the "SetProductionEnv" macro. '** SETUP: Copy the Peachtree Alert, Alarm and Eventlog file to the Peachtree '** program directory to eliminate problem with Peachtree DDE Open. '** USAGE: '** Step 1 '** Make all employee & customer updates within Peachtree. Import the Peachtree '** Employee & Customer information into this worksheet by clicking on the Update '** button on the Employee_List & Customer_List screen. '** Step 2 '** Enter the current periods employee time sheet information into the Payroll '** worksheet Payroll_Entry screen. '** "Add" Button - Add an additional line to the Payroll_Entry screen for '** time sheet data entry. (Ctrl-C) '** "Input / Edit" Button - Display the time sheet data entry form for '** time sheet input & editing. (Ctrl-E) '** "Sort By Emp" Button - Sorts time sheet data by Employee ID. '** "Sort By Dept" Button - Sorts time sheet data by Department. '** "Sort By Cust" Button - Sorts time sheet data by Customer ID. '** "Print" Button - Print entire payroll entry sheet. '** "Reset" Button - Delete previously entered time sheet data. '** Step 3 '** Calculate employee payroll deductions by clicking on the Update button on the '** Payroll worksheet Payroll_Calc screen. Only enter additional employee income '** and deduction after clicking on the Update button. Clicking on the Update button '** will reset any previously entered special payroll income or deductions. Additional '** income should be entered as a positive number and deductions as a negative number. '** Step 4 '** Create Peachtree payroll & invoice transactions by clicking on the Generate_Invoice '** and/or Generate_Payroll button on the Payroll worksheet Payroll_Calc screen. '** This step will take a while to complete and may be run overnight. Peachtree '** accounting files should be backed up immediately prior to generating payroll '** or invoice transactions. If a major error is discovered after the transactions '** are generated, the Peachtree accounting files should be restored from the backup. '** Step 5 '** Print and verify Peachtree payroll & sales reports. Print customer invoices and '** payroll checks from within Peachtree. '** PROCEDURES: '** AddPayrollEntry - Add an additional line to Payroll_Entry sheet. '** ConvertDeptToAccount - Return PAW account # for department. '** DefineNamedRanges - Define worksheet named ranges (Development). '** DefinePayrollEntryFormulas - Build Payroll_Entry total formulas. '** EditPayrollEntry - Allow data entry into Payroll_Entry sheet. '** FIT - Return federal income tax deduction. '** FICA - Return Social Security tax deduction. '** FUTA - Return employer FUTA. '** GenerateAll - Generate payroll & invoice transactions. '** GenerateInvoice - Generate Peachtree invoice transactions. '** GeneratePayroll - Generate Peachtree payroll transactions. '** GetPayroll - Retrieve poked payroll for verification (Development). '** GetSales - Retrieve poked invoices for verification (Development). '** PayFrequencyAnnualConvFactor - Returns employee pay frequency conv factor. '** PSLookup - Returns lookup value from PS_TData table. '** PrintSelectedSheet - Print current worksheet. '** ResetPayrollEntry - Clear contents of Payroll_Entry sheet. '** SetDevelopmentEnv - Unprotect & restore development settings (Development). '** SetProductionEnv - Protect & restore production settings (Development). '** SIT - Return state income tax deduction. '** Sub SortByBillRate - Sort PE_Data by Bill Rate. '** SortByCustomer - Sort PE_Data by Customer ID. '** SortByDate- Sort PE_Data by Date. '** SortByDepartment - Sort PE_Data by Department. '** SortByEmployee - Sort PE_Data by Employee ID. '** Sub SortByPayRate - Sort PE_Data by Pay Rate. '** SUI - Return employer SUI. '** UpdateCustomerList - Update Customer_List from Peachtree files. '** UpdateDeptSum - Recalc Dept_Sum pivot table. '** UpdatePayrollEntry - Update Payroll Entry table department and rate formulas. '** UpdateEmplyeeList - Update Employee_List from Peachtree files. '** UpdatePayrollCalc - Update & recalc Payroll_Calc sheet. '** UpdatePayrollSum - Recalc Payroll_Sum pivot table. '************************************************* ************************** '************************************************* ************************** '** D E C L A R E M O D U L E - L E V E L C O N S T A N T S '************************************************* ************************** 'Const COMPANY = "MARCHINC" ' Company Short Name" Const COMPANY = "AGENCY" ' Company Short Name" Const PROGRAM = "C:\PEACHW\PEACHW.EXE" ' Program Exec Name Const CL_DATA_ROW = 6 ' CL First Customer Data Row Const EL_DATA_ROW = 6 ' EL First Employee Data Row Const EL_STATUS = 4 ' EL "Status" Column Number Const EL_PAY_FREQ = 5 ' EL "Frequency" Column Number Const EL_FED_ALLOW = 6 ' EL "Fed.Allow" Column Number Const EL_EXTRA_FIT = 7 ' EL "Extra.FIT" Column Number Const EL_EXTRA_SIT = 11 ' EL "Extra.SIT" Column Number Const EL_STATE_ALLOW = 8 ' EL "KS.Allow" Column Number Const EL_YTD_GROSS = 9 ' EL "YTD.Gross" Column Number Const PC_DATA_ROW = 10 ' PC First Employee Data Row Const PC_DIST_COLUMN = 7 ' PC First Distribution Comumn Const PE_DATA_ROW = 8 ' PE First Employee Data Row '************************************************* ************************** '** D E C L A R E M O D U L E - L E V E L V A R I A B L E S '************************************************* ************************** Dim CPointer As Integer ' Current Worksheet Column Dim RPointer As Integer ' Current Worksheet Row Dim Channel As Integer ' DDE Conversation Ref Dim PAWData As Variant ' Requested PAW Hdr Data Dim PAWDist As Variant ' Requested PAW Dist Data '************************************************* ************************** '** AddPayrollEntry F U N C T I O N '************************************************* ************************** Sub AddPayrollEntry() Application.ScreenUpdating = False Sheets("Payroll_Entry").Unprotect RPointer = Range("Payroll_Entry!A7").End(xlDown).Row Range("PE_Formula").EntireRow.Hidden = False Range("PE_Formula").Copy Sheets("Payroll_Entry").Rows(RPointer + 1).Insert Shift:=xlDown Range("PE_Formula").EntireRow.Hidden = True ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True End Sub '************************************************* ************************** '** ConvertDeptToAccount F U N C T I O N '************************************************* ************************** Function ConvertDeptToAccount(Dept) If (VarType(Dept) = vbString) Then Dept = Val(Right(Dept, 3)) End If Select Case Dept Case 100 ConvertDeptToAccount = 511100 Case 119 ConvertDeptToAccount = 525120 Case 120 ConvertDeptToAccount = 511120 Case 125 ConvertDeptToAccount = 525126 Case 126 ConvertDeptToAccount = 511126 Case 128 ConvertDeptToAccount = 525129 Case 129 ConvertDeptToAccount = 511129 Case 131 ConvertDeptToAccount = 511131 Case 133 ConvertDeptToAccount = 511133 Case 135 ConvertDeptToAccount = 511135 Case 140 ConvertDeptToAccount = 511140 Case 141 ConvertDeptToAccount = 511141 Case 142 ConvertDeptToAccount = 511142 Case 145 ConvertDeptToAccount = 511145 Case 150 ConvertDeptToAccount = 511150 Case 151 ConvertDeptToAccount = 511151 Case 152 ConvertDeptToAccount = 511152 Case 155 ConvertDeptToAccount = 511155 Case 159 ConvertDeptToAccount = 511159 Case 160 ConvertDeptToAccount = 511160 Case 161 ConvertDeptToAccount = 511161 Case 162 ConvertDeptToAccount = 511162 Case 163 ConvertDeptToAccount = 511163 Case 164 ConvertDeptToAccount = 511164 Case 165 ConvertDeptToAccount = 511165 Case 166 ConvertDeptToAccount = 511166 Case 167 ConvertDeptToAccount = 511167 Case 170 ConvertDeptToAccount = 511170 Case 172 ConvertDeptToAccount = 511172 Case 173 ConvertDeptToAccount = 511173 Case 174 ConvertDeptToAccount = 511174 Case 175 ConvertDeptToAccount = 511175 Case 176 ConvertDeptToAccount = 511176 Case 180 ConvertDeptToAccount = 511180 Case 182 ConvertDeptToAccount = 511182 Case 195 ConvertDeptToAccount = 511195 Case 196 ConvertDeptToAccount = 511196 Case 200 ConvertDeptToAccount = 511200 Case 219 ConvertDeptToAccount = 525220 Case 220 ConvertDeptToAccount = 511220 Case 225 ConvertDeptToAccount = 525226 Case 226 ConvertDeptToAccount = 511226 Case 228 ConvertDeptToAccount = 525229 Case 229 ConvertDeptToAccount = 511229 Case 231 ConvertDeptToAccount = 511231 Case 233 ConvertDeptToAccount = 511233 Case 235 ConvertDeptToAccount = 511235 Case 240 ConvertDeptToAccount = 511240 Case 245 ConvertDeptToAccount = 511245 Case 250 ConvertDeptToAccount = 511250 Case 251 ConvertDeptToAccount = 511251 Case 252 ConvertDeptToAccount = 511252 Case 260 ConvertDeptToAccount = 511260 Case 261 ConvertDeptToAccount = 511261 Case 262 ConvertDeptToAccount = 511262 Case 263 ConvertDeptToAccount = 511263 Case 264 ConvertDeptToAccount = 511264 Case 265 ConvertDeptToAccount = 511265 Case 266 ConvertDeptToAccount = 511266 Case 267 ConvertDeptToAccount = 511267 Case 270 ConvertDeptToAccount = 511270 Case 272 ConvertDeptToAccount = 511272 Case 274 ConvertDeptToAccount = 511274 Case 275 ConvertDeptToAccount = 511275 Case 276 ConvertDeptToAccount = 511276 Case 280 ConvertDeptToAccount = 511280 Case 282 ConvertDeptToAccount = 511282 Case 295 ConvertDeptToAccount = 511295 Case 296 ConvertDeptToAccount = 511296 Case 300 ConvertDeptToAccount = 511300 Case 319 ConvertDeptToAccount = 525320 Case 320 ConvertDeptToAccount = 511320 Case 325 ConvertDeptToAccount = 525326 Case 326 ConvertDeptToAccount = 511326 Case 328 ConvertDeptToAccount = 525329 Case 329 ConvertDeptToAccount = 511329 Case 331 ConvertDeptToAccount = 511331 Case 333 ConvertDeptToAccount = 511333 Case 335 ConvertDeptToAccount = 511335 Case 338 ConvertDeptToAccount = 511338 Case 339 ConvertDeptToAccount = 511339 Case 340 ConvertDeptToAccount = 511340 Case 341 ConvertDeptToAccount = 511341 Case 345 ConvertDeptToAccount = 511345 Case 350 ConvertDeptToAccount = 511350 Case 351 ConvertDeptToAccount = 511351 Case 352 ConvertDeptToAccount = 511352 Case 360 ConvertDeptToAccount = 511360 Case 361 ConvertDeptToAccount = 511361 Case 362 ConvertDeptToAccount = 511362 Case 363 ConvertDeptToAccount = 511363 Case 364 ConvertDeptToAccount = 511364 Case 365 ConvertDeptToAccount = 511365 Case 366 ConvertDeptToAccount = 511366 Case 367 ConvertDeptToAccount = 511367 Case 370 ConvertDeptToAccount = 511370 Case 372 ConvertDeptToAccount = 511372 Case 374 ConvertDeptToAccount = 511374 Case 375 ConvertDeptToAccount = 511375 Case 376 ConvertDeptToAccount = 511376 Case 395 ConvertDeptToAccount = 511395 Case 396 ConvertDeptToAccount = 511396 Case 419 ConvertDeptToAccount = 525420 Case 420 ConvertDeptToAccount = 511420 Case 425 ConvertDeptToAccount = 525426 Case 426 ConvertDeptToAccount = 511426 Case 428 ConvertDeptToAccount = 525429 Case 429 ConvertDeptToAccount = 511429 Case 431 ConvertDeptToAccount = 511431 Case 433 ConvertDeptToAccount = 511433 Case 435 ConvertDeptToAccount = 511435 Case 436 ConvertDeptToAccount = 511436 Case 439 ConvertDeptToAccount = 511439 Case 440 ConvertDeptToAccount = 511440 Case 441 ConvertDeptToAccount = 511441 Case 445 ConvertDeptToAccount = 511445 Case 450 ConvertDeptToAccount = 511450 Case 451 ConvertDeptToAccount = 511451 Case 452 ConvertDeptToAccount = 511452 Case 460 ConvertDeptToAccount = 511460 Case 461 ConvertDeptToAccount = 511461 Case 462 ConvertDeptToAccount = 511462 Case 463 ConvertDeptToAccount = 511463 Case 464 ConvertDeptToAccount = 511464 Case 465 ConvertDeptToAccount = 511465 Case 466 ConvertDeptToAccount = 511466 Case 467 ConvertDeptToAccount = 511467 Case 470 ConvertDeptToAccount = 511470 Case 472 ConvertDeptToAccount = 511472 Case 474 ConvertDeptToAccount = 511474 Case 475 ConvertDeptToAccount = 511475 Case 476 ConvertDeptToAccount = 511476 Case 480 ConvertDeptToAccount = 511480 Case 562 ConvertDeptToAccount = 511562 Case 563 ConvertDeptToAccount = 511563 Case 566 ConvertDeptToAccount = 511566 Case 572 ConvertDeptToAccount = 511572 Case 576 ConvertDeptToAccount = 511576 Case 580 ConvertDeptToAccount = 511580 Case 633 ConvertDeptToAccount = 511633 Case 640 ConvertDeptToAccount = 511640 Case 662 ConvertDeptToAccount = 511662 Case 663 ConvertDeptToAccount = 511663 Case 672 ConvertDeptToAccount = 511672 Case 676 ConvertDeptToAccount = 511676 Case Else ConvertDeptToAccount = 51200 End Select End Function '************************************************* ************************** '** DefineNamedRanges F U N C T I O N '************************************************* ************************** Sub DefineNamedRanges() SetDevelopmentEnv ' CL_Data - Customer_List ID & Name range wo/column headings. ' Defined in UpdateCustomerList ' EL_Data - Employee_List ID & Name range wo/column headings. ' Defined in UpdateEmployeeList ' EL_ID - Employee_List ID range wo/column heading. ' Defined in UpdateEmployeeList ' I_Account - Invoice Account # distribution work area. Names.Add Name:="I_Account", RefersToR1C1:="=Work!R5C2" ' I_Amount - Invoice Amount distribution work area. Names.Add Name:="I_Amount", RefersToR1C1:="=Work!R5C3" ' I_Description - Invoice Description distribution work area. Names.Add Name:="I_Description", RefersToR1C1:="=Work!R5C6" ' I_Distribution - Work area for poking invoice distribution. Names.Add Name:="I_Distribution", RefersToR1C1:="=Work!R5C2:R5C9" ' I_Item - Invoice Item distribution work area. Names.Add Name:="I_Item", RefersToR1C1:="=Work!R5C4" ' I_Quanity - Invoice Quanity distribution work area. Names.Add Name:="I_Quanity", RefersToR1C1:="=Work!R5C5" ' P_Account - Payroll Account # distribution work area. Names.Add Name:="P_Account", RefersToR1C1:="=Work!R3C2" ' P_Amount - Payroll Amount distribution work area. Names.Add Name:="P_Amount", RefersToR1C1:="=Work!R3C3" ' P_CheckDate - Payroll CheckDate header work area. Names.Add Name:="P_CheckDate", RefersToR1C1:="=Work!R7C2" ' P_Distribution - Work area for poking payroll distribution. Names.Add Name:="P_Distribution", RefersToR1C1:="=Work!R3C2:R3C5" ' P_Employee - Payroll Employee header work area. Names.Add Name:="P_Employee", RefersToR1C1:="=Work!R7C3" ' P_Field - Payroll Field distribution work area. Names.Add Name:="P_Field", RefersToR1C1:="=Work!R3C4" ' P_Header - Payroll header work area. Names.Add Name:="P_Header", RefersToR1C1:="=Work!R7C2:R7C6" ' P_RegHours - Payroll RegHours header work area. Names.Add Name:="P_RegHours", RefersToR1C1:="=Work!R7C4" ' P_SpecHours - Payroll SpecHours header work area. Names.Add Name:="P_SpecHours", RefersToR1C1:="=Work!R7C6" ' P_OTHours - Payroll OTHours header work area. Names.Add Name:="P_OTHours", RefersToR1C1:="=Work!R7C5" ' PC_Formula - Payroll_Calc table summary formula row. Names.Add Name:="PC_Formula", RefersToR1C1:="=Payroll_Calc!R4:R5" ' PE_CheckDate - Payroll_Entry "Check Date". Names.Add Name:="PE_CheckDate", RefersToR1C1:="=Payroll_Entry!R1C11" ' PE_Data - Payroll_Entry Timesheet entry range wo/column headings. ' Defined in DefinePayrollEntryFormulas ' PE_Formula - Payroll_Entry data entry formula row. Names.Add Name:="PE_Formula", RefersToR1C1:="=Payroll_Entry!R5:R5" ' PE_Header - Payroll_Entry header rows. Names.Add Name:="PE_Header", RefersToR1C1:="=Payroll_Entry!R1:R6" ' PE_InvoiceDate - Payroll_Entry "Invoice Date". Names.Add Name:="PE_InvoiceDate", RefersToR1C1:="=Payroll_Entry!R3C11" ' PE_PeriodEndDate - Payroll_Entry "Period End Date". Names.Add Name:="PE_PeriodEndDate", RefersToR1C1:="=Payroll_Entry!R2C11" ' PE_Table - Payroll_Entry Timesheet entry range w/column headings. ' Defined in DefinePayrollEntryFormulas ' PC_TData - Pivot table w/total column header wo/row desc. ' Defined in UpdatePayrollSum ' PWord - DDE Link PWord. Names.Add Name:="PWord", RefersToR1C1:="=Work!R1C2" ' S_Counter - Status of current procedure. Names.Add Name:="S_Counter", RefersToR1C1:="=Status!R5C3" ' S_Function - Description of current procedure. Names.Add Name:="S_Function", RefersToR1C1:="=Status!R3C3" ' DS_PT - Dept_Sum pivot table name. ' PS_PT - Payroll_Sum pivot table name. DefinePayrollEntryFormulas End Sub '************************************************* ************************** '** DefinePayrollEntryFormulas F U N C T I O N '************************************************* ************************** Sub DefinePayrollEntryFormulas() Sheets("Payroll_Entry").Unprotect RPointer = Range("Payroll_Entry!A7").End(xlDown).Row + 1 Range("Payroll_Entry!C6").Formula = "=COUNTA(C8:C" & Format(RPointer) & ")" Range("Payroll_Entry!D6").Formula = "=COUNT(D8:D" & Format(RPointer) & ")" Range("Payroll_Entry!E6").Formula = "=COUNT(E8:E" & Format(RPointer) & ")" Range("Payroll_Entry!F6").Formula = "=COUNT(F8:F" & Format(RPointer) & ")" Range("Payroll_Entry!G6").Formula = "=COUNT(G8:G" & Format(RPointer) & ")" Range("Payroll_Entry!H6").Formula = "=SUM(H8:H" & Format(RPointer) & ")" Range("Payroll_Entry!I6").Formula = "=COUNTA(I8:I" & Format(RPointer) & ")" Range("Payroll_Entry!J6").Formula = "=COUNT(J8:J" & Format(RPointer) & ")" Range("Payroll_Entry!K6").Formula = "=COUNT(K8:K" & Format(RPointer) & ")" Range("Payroll_Entry!L6").Formula = "=COUNTA(L8:L" & Format(RPointer) & ")" Range("Payroll_Entry!M6").Formula = "=COUNTA(M8:M" & Format(RPointer) & ")" ' Range("Payroll_Entry!N6").Formula = "=SUMIF(N8:N" & Format(RPointer) & ',">0")' ' Range("Payroll_Entry!O6").Formula = "=SUM(O8:O" & Format(RPointer) & ")" Names.Add Name:="PE_Data", RefersToR1C1:= _ Sheets("Payroll_Entry").Range(Cells(8, 3), Cells(RPointer, 12)) Names.Add Name:="PE_Table", RefersToR1C1:= _ Sheets("Payroll_Entry").Range(Cells(7, 2), Cells(RPointer, 16)) ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True End Sub '************************************************* ************************** '** EditPayrollEntry F U N C T I O N '************************************************* ************************** Sub EditPayrollEntry() Application.ScreenUpdating = False Sheets("Payroll_Entry").Unprotect ' Remove worksheet headers Range("PE_Header").Select Range("PE_Header").Cut ActiveSheet.Paste destination:=Sheets("Work").Range("A10") Sheets("Payroll_Entry").Select Selection.Delete Shift:=xlUp ' Display input form ActiveSheet.ShowDataForm ' Replace worksheet headers Range("PE_Header").Cut Sheets("Payroll_Entry").Rows("1:1").Insert Shift:=xlUp DefinePayrollEntryFormulas Sheets("Work").Visible = False ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True SendKeys ("{End}{Home}{Home}{End}{UP}") End Sub '************************************************* ************************** '** FICA F U N C T I O N '************************************************* ************************** Function FICA(Employee, AdjGross) If IsError(Employee) Then FICA = 0: Exit Function EmpYtdGross = Range("Employee_List!A5").Offset(Employee, EL_YTD_GROSS - 1) If (AdjGross + EmpYtdGross) > 90000 Then If AdjGross > 90000 Then FICA = 0 Else FICA = Application.Round((90000 - EmpYtdGross) * 0.062, 2) End If Else FICA = Application.Round(AdjGross * 0.062, 2) End If End Function '************************************************* ************************** '** FIT F U N C T I O N '************************************************* ************************** Function FIT(Employee, AdjGross) If IsError(Employee) Then FIT = 0: Exit Function ConvFactor = PayFrequencyAnnualConvFactor(Employee) AnnualGross = (AdjGross * ConvFactor) - _ (Range("Employee_List!A5").Offset(Employee, EL_FED_ALLOW - 1) * 3200) If Range("Employee_List!A5").Offset(Employee, EL_STATUS - 1) = "Single" Then If AnnualGross <= 2650 Then Table = 0 ElseIf AnnualGross <= 9800 Then Table = (AnnualGross - 2650) * 0.1 ElseIf AnnualGross <= 31500 Then Table = 715 + ((AnnualGross - 9800) * 0.15) ElseIf AnnualGross <= 69750 Then Table = 3970 + ((AnnualGross - 31500) * 0.25) ElseIf AnnualGross <= 151950 Then Table = 13532.5 + ((AnnualGross - 69750) * 0.28) ElseIf AnnualGross <= 328250 Then Table = 36548.5 + ((AnnualGross - 151950) * 0.33) Else Table = 94727.5 + ((AnnualGross - 328250) * 0.35) End If Else If AnnualGross <= 8000 Then Table = 0 ElseIf AnnualGross <= 22600 Then Table = (AnnualGross - 8000) * 0.1 ElseIf AnnualGross <= 66200 Then Table = 1460 + ((AnnualGross - 22600) * 0.15) ElseIf AnnualGross <= 120750 Then Table = 8000 + ((AnnualGross - 66200) * 0.25) ElseIf AnnualGross <= 189600 Then Table = 21637.5 + ((AnnualGross - 120750) * 0.28) ElseIf AnnualGross <= 333250 Then Table = 40915.5 + ((AnnualGross - 189600) * 0.33) Else Table = 88320 + ((AnnualGross - 333250) * 0.35) End If End If FIT = -Application.Round((Table / ConvFactor) + _ Range("Employee_List!A5").Offset(Employee, EL_EXTRA_FIT - 1), 2) End Function '************************************************* ************************** '** FUTA F U N C T I O N '************************************************* ************************** Function FUTA(Employee, AdjGross) If IsError(Employee) Then FUTA = 0: Exit Function EmpYtdGross = Range("Employee_List!A5").Offset(Employee, EL_YTD_GROSS - 1) If (AdjGross + EmpYtdGross) > 7000 Then If EmpYtdGross > 7000 Then FUTA = 0 Else FUTA = Application.Round((7000 - EmpYtdGross) * 0.008, 2) End If Else FUTA = Application.Round(AdjGross * 0.008, 2) End If End Function '************************************************* ************************** '** GenerateAll F U N C T I O N '************************************************* ************************** Sub GenerateAll() GeneratePayroll GenerateInvoice End Sub |
#4
|
|||
|
|||
RE: Macros problem with XP
Here is the second part.
'************************************************* ************************** '** GenerateInvoice F U N C T I O N '************************************************* ************************** Sub GenerateInvoice() Range("S_Function").Formula = "Generating Invoice Transactions" Range("S_Counter").Formula = 0 Sheets("Status").Visible = True Sheets("Status").Select Application.ScreenUpdating = False Sheets("Payroll_Entry").Select 'SortByCustomer On Error GoTo ErrorHandler ' Enable error-handling routine. ' Channel = Application.DDEInitiate("PeachW", COMPANY) ' DDEPoke Channel, "Password", Range("PWord") Sheets("Status").Select RPointer = PE_DATA_ROW Application.Calculation = xlManual Application.ScreenUpdating = True Do Until IsEmpty(Sheets("Payroll_Entry").Cells(RPointer, 13)) Or _ IsError(Sheets("Payroll_Entry").Cells(RPointer, 13)) If Sheets("Payroll_Entry").Cells(RPointer, 11) > 0 Then Channel = Application.DDEInitiate("PeachW", COMPANY) DDEPoke Channel, "Password", Range("PWord") ' Poke Invoice Header DDEPoke Channel, "file=salesjournal,clear,field=customer", _ Sheets("Payroll_Entry").Cells(RPointer, 12) DDEPoke Channel, "file=salesjournal,field=date", Range("PE_InvoiceDate") Do ' Poke Each Disbursment Range("S_Counter").Formula = RPointer - 7 Range("I_Account").Formula = ConvertDeptToAccount _ (Worksheets("Payroll_Entry").Cells(RPointer, 4).Value) Range("I_Amount").Formula = _ Worksheets("Payroll_Entry").Cells(RPointer, 15).Value * -1 Range("I_Quanity").Formula = _ Worksheets("Payroll_Entry").Cells(RPointer, 8).Value Range("I_Description").Formula = Format(Worksheets("Payroll_Entry"). _ Cells(RPointer, 7).Value, "00000") + " " + Format(Worksheets _ ("Payroll_Entry").Cells(RPointer, 6).Value, "mm/dd/yyyy") + _ " " + CStr(Worksheets("Payroll_Entry").Cells(RPointer, 2).Value) If Worksheets("Payroll_Entry").Cells(RPointer, 12) = _ Worksheets("Payroll_Entry").Cells(RPointer + 1, 12) _ Then DDEPoke Channel, "file=salesjournal,field=nextdistribution", _ Range("I_Distribution") _ Else DDEPoke Channel, "file=salesjournal,field=nextdistribution,save ", _ Range("I_Distribution") RPointer = RPointer + 1 Loop While Worksheets("Payroll_Entry").Cells(RPointer, 12) = _ Worksheets("Payroll_Entry").Cells(RPointer - 1, 12) Application.DDETerminate (Channel) Else RPointer = RPointer + 1 End If Loop Application.Calculation = xlAutomatic Application.ScreenUpdating = False ' Application.DDETerminate (Channel) Sheets("Payroll_Calc").Select Sheets("Status").Visible = False Exit Sub ' Exit Sub before error handler. ErrorHandler: ' Error-handling routine. Sheets("Status").Visible = False Sheets("Payroll_Calc").Select MsgBox ("The Peachtree accounting program must be running in the background before running this function. Start Peachtree then try again.") End End Sub '************************************************* ************************** '** GeneratePayroll F U N C T I O N '************************************************* ************************** Sub GeneratePayroll() Range("S_Function").Formula = "Generating Payroll Transactions" Range("S_Counter").Formula = 0 Sheets("Status").Visible = True Sheets("Status").Select Application.ScreenUpdating = False On Error GoTo ErrorHandler ' Enable error-handling routine. ' Channel = Application.DDEInitiate("PeachW", COMPANY) ' DDEPoke Channel, "Password", Range("PWord") RPointer = PC_DATA_ROW Range("P_CheckDate").Formula = Range("PE_CheckDate") Sheets("Status").Select Application.ScreenUpdating = True Do Until IsEmpty(Sheets("Payroll_Calc").Cells(RPointer, 2)) Or _ IsError(Sheets("Payroll_Calc").Cells(RPointer, 2)) Channel = Application.DDEInitiate("PeachW", COMPANY) DDEPoke Channel, "Password", Range("PWord") CPointer = PC_DIST_COLUMN Range("S_Counter").Formula = (RPointer - 8) / 2 ' Poke Payroll Header Range("P_Employee").Formula = _ Worksheets("Payroll_Calc").Cells(RPointer, 3) Range("P_RegHours").Formula = _ Worksheets("Payroll_Calc").Cells(RPointer, 4) Range("P_OTHours").Formula = _ Worksheets("Payroll_Calc").Cells(RPointer, 5) Range("P_SpecHours").Formula = _ Worksheets("Payroll_Calc").Cells(RPointer, 6) DDEPoke Channel, "file=payrolljournal,clear,field=date,field=employ ee,field=regularhours,field=overtimehours,field=sp ecialhours", Range("P_Header") ' Poke Each Disbursment Do Until IsEmpty(Worksheets("Payroll_Calc").Cells(7, CPointer)) Range("S_Counter").Formula = Format(((RPointer - 8) / 2) + _ ((CPointer - 6) / 100), "0.00") ' Poke First Disbursment If Worksheets("Payroll_Calc").Cells(RPointer + 1, CPointer) > 0 _ Then Range("P_Account").Formula = Worksheets("Payroll_Calc") _ .Cells(RPointer + 1, CPointer).Value _ Else Range("P_Account").Formula = Worksheets("Payroll_Calc") _ .Cells(7, CPointer).Value Range("P_Amount").Formula = Worksheets("Payroll_Calc") _ .Cells(RPointer, CPointer).Value Range("P_Field").Formula = Worksheets("Payroll_Calc") _ .Cells(6, CPointer).Value CPointer = CPointer + 1 If IsEmpty(Worksheets("Payroll_Calc").Cells(7, CPointer)) _ Then DDEPoke Channel, "file=payrolljournal,field=nextdistribution,sa ve", _ Range("P_Distribution") _ Else DDEPoke Channel, "file=payrolljournal,field=nextdistribution", _ Range("P_Distribution") Loop Application.DDETerminate (Channel) RPointer = RPointer + 2 Loop Application.ScreenUpdating = False ' Application.DDETerminate (Channel) Sheets("Payroll_Calc").Select Sheets("Status").Visible = False Exit Sub ' Exit Sub before error handler. ErrorHandler: ' Error-handling routine. Sheets("Status").Visible = False Sheets("Payroll_Calc").Select MsgBox ("The Peachtree accounting program must be running in the background before running this function. Start Peachtree then try again.") End End Sub '************************************************* ************************** '** GetPayroll F U N C T I O N '************************************************* ************************** Sub GetPayroll() ' Used only for test purposes Application.Calculation = xlManual RPointer = 2 Sheets("Test").Select Range("A1.AA9999").ClearContents On Error GoTo ErrorHandler ' Enable error-handling routine. Channel = Application.DDEInitiate("PeachW", COMPANY) DDEPoke Channel, "Password", Range("PWord") PAWData = DDERequest(Channel, "file=payrolljournal,first,field=employee,field=in voice,field=weeks,field=date,field=description,fie ld=account,field=amount,field=regularhours,field=o vertimehours,field=specialhours") While Not IsError(PAWData) For CPointer = LBound(PAWData) To UBound(PAWData) Worksheets("Test").Cells(RPointer, CPointer).Formula = PAWData(CPointer) Next CPointer RPointer = RPointer + 1 PAWDist = DDERequest(Channel, "file=payrolljournal,field=firstdistribution") While Not IsError(PAWDist) For CPointer = LBound(PAWDist) To UBound(PAWDist) Worksheets("Test").Cells(RPointer, CPointer + 1).Formula = _ PAWDist(CPointer) Next CPointer PAWDist = DDERequest(Channel, _ "file=payrolljournal,field=nextdistribution") RPointer = RPointer + 1 Wend PAWData = DDERequest(Channel, "file=payrolljournal,next,field=employee,field=inv oice,field=weeks,field=date,field=description,fiel d=account,field=amount,field=regularhours,field=ov ertimehours,field=specialhours") Wend Application.DDETerminate (Channel) Application.Calculation = xlAutomatic Exit Sub ' Exit Sub before error handler. ErrorHandler: ' Error-handling routine. Application.Calculation = xlAutomatic MsgBox ("The Peachtree accounting program must be running in the background before running this function. Start Peachtree then try again.") Exit Sub End Sub '************************************************* ************************** '** GetSales F U N C T I O N '************************************************* ************************** Sub GetSales() ' Used only for test purposes Application.Calculation = xlManual RPointer = 2 Sheets("Test").Select Range("A1.AA9999").ClearContents On Error GoTo ErrorHandler ' Enable error-handling routine. Channel = Application.DDEInitiate("PeachW", COMPANY) DDEPoke Channel, "Password", Range("PWord") PAWData = DDERequest(Channel, "file=salesjournal,first,field=invoice,field=date, field=description,field=account,field=amount") While Not IsError(PAWData) For CPointer = LBound(PAWData) To UBound(PAWData) Worksheets("Test").Cells(RPointer, CPointer).Formula = PAWData(CPointer) Next CPointer RPointer = RPointer + 1 PAWDist = DDERequest(Channel, "file=salesjournal,field=firstdistribution") While Not IsError(PAWDist) For CPointer = LBound(PAWDist) To UBound(PAWDist) Worksheets("Test").Cells(RPointer, CPointer + 1).Formula = _ PAWDist(CPointer) Next CPointer PAWDist = DDERequest(Channel, _ "file=salesjournal,field=nextdistribution") RPointer = RPointer + 1 Wend PAWData = DDERequest(Channel, "file=salesjournal,next,field=invoice,field=date,f ield=description,field=account,field=amount") Wend Application.DDETerminate (Channel) Application.Calculation = xlAutomatic Exit Sub ' Exit Sub before error handler. ErrorHandler: ' Error-handling routine. Application.Calculation = xlAutomatic MsgBox ("The Peachtree accounting program must be running in the background before running this function. Start Peachtree then try again.") Exit Sub End Sub '************************************************* ************************** '** PayFrequencyAnnualConvFactor F U N C T I O N '************************************************* ************************** Function PayFrequencyAnnualConvFactor(Employee) PayFrequency = Range("Employee_List!A5").Offset(Employee, EL_PAY_FREQ - 1) Select Case PayFrequency Case "Weekly" PayFrequencyAnnualConvFactor = 52 Case "Bi-Weekly" PayFrequencyAnnualConvFactor = 26 Case "Semi-Monthly" PayFrequencyAnnualConvFactor = 24 Case "Monthly" PayFrequencyAnnualConvFactor = 12 Case Else PayFrequencyAnnualConvFactor = 1 End Select End Function '************************************************* ************************** '** PrintSheet P R O C E D U R E '************************************************* ************************** Sub PrintSelectedSheet() ActiveWindow.SelectedSheets.PrintOut Copies:=1 End Sub '************************************************* ************************** '** ResetPayrollEntry P R O C E D U R E '************************************************* ************************** Sub ResetPayrollEntry() Application.ScreenUpdating = False Sheets("Payroll_Entry").Unprotect Sheets("Payroll_Entry").Range(Rows(PE_DATA_ROW), Rows(999)).Delete Shift:=xlUp Range("PE_Formula").EntireRow.Hidden = False Sheets("Payroll_Entry").Range("PE_Formula").Copy ' Formula row ActiveSheet.Paste destination:=Sheets("Payroll_Entry").Rows(PE_DATA_ ROW) Range("PE_Formula").EntireRow.Hidden = True DefinePayrollEntryFormulas ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True SendKeys ("^{Home}") End Sub '************************************************* ************************** '** SetDevelopmentEnv F U N C T I O N '************************************************* ************************** Sub SetDevelopmentEnv() Application.ScreenUpdating = False ' Workbook settings ActiveWindow.WindowState = xlNormal Application.DisplayFormulaBar = True Toolbars(1).Visible = True ' Payroll_Entry screen settings Sheets("Payroll_Entry").Select ActiveSheet.Unprotect Rows("5:5").EntireRow.Hidden = False Columns("P:P").EntireColumn.Hidden = False ActiveWindow.DisplayHeadings = True ' Payroll_Calc screen settings Sheets("Payroll_Calc").Select ActiveSheet.Unprotect Rows("4:6").EntireRow.Hidden = False Columns("J:Z").EntireColumn.Hidden = False Columns("AL:AO").EntireColumn.Hidden = False ActiveWindow.DisplayHeadings = True ' Payroll_Sum screen settings Sheets("Payroll_Sum").Select ActiveSheet.Unprotect ActiveWindow.DisplayHeadings = True ' Dept_Sum screen settings Sheets("Dept_Sum").Select ActiveSheet.Unprotect ActiveWindow.DisplayHeadings = True ' Customer_List screen settings Sheets("Customer_List").Select ActiveSheet.Unprotect ActiveWindow.DisplayHeadings = True ' Employee_List screen settings Sheets("Employee_List").Select ActiveSheet.Unprotect ActiveWindow.DisplayHeadings = True ' Status screen settings Sheets("Status").Visible = True Sheets("Status").Select ActiveSheet.Unprotect ActiveWindow.DisplayHeadings = True ' Work screen settings Sheets("Work").Visible = True Sheets("Work").Select ActiveSheet.Unprotect ActiveWindow.DisplayHeadings = True ' Logic screen settings Sheets("Logic").Visible = True Sheets("Logic").Select ActiveSheet.Unprotect Sheets("Payroll_Entry").Select End Sub '************************************************* ************************** '** SetProductionEnv F U N C T I O N '************************************************* ************************** Sub SetProductionEnv() Application.ScreenUpdating = False DefineNamedRanges ' Workbook settings ActiveWindow.WindowState = xlMaximized Application.DisplayFormulaBar = False Toolbars(1).Visible = False Toolbars(2).Visible = False Toolbars(5).Visible = False ' Payroll_Entry screen settings Sheets("Payroll_Entry").Select ActiveSheet.Unprotect Rows("5:5").EntireRow.Hidden = True Columns("P:P").EntireColumn.Hidden = True ActiveWindow.DisplayHeadings = False ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True SendKeys ("^{Home}") ' Payroll_Calc screen settings Sheets("Payroll_Calc").Select ActiveSheet.Unprotect Rows("4:6").EntireRow.Hidden = True Columns("J:Z").EntireColumn.Hidden = True Columns("AL:AO").EntireColumn.Hidden = True ActiveWindow.DisplayHeadings = False ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True SendKeys ("^{Home}") ' Payroll_Sum screen settings Sheets("Payroll_Sum").Select ActiveWindow.DisplayHeadings = False ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True SendKeys ("^{Home}") ' Dept_Sum screen settings Sheets("Dept_Sum").Select ActiveWindow.DisplayHeadings = False ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True SendKeys ("^{Home}") ' Customer_List screen settings Sheets("Customer_List").Select ActiveWindow.DisplayHeadings = False ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True SendKeys ("^{Home}") ' Employee_List screen settings Sheets("Employee_List").Select ActiveWindow.DisplayHeadings = False ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True SendKeys ("^{Home}") ' Status screen settings Sheets("Status").Visible = True Sheets("Status").Select ActiveWindow.DisplayHeadings = False ActiveSheet.Visible = False ' Work screen settings Sheets("Work").Visible = True Sheets("Work").Select ActiveWindow.DisplayHeadings = False ActiveSheet.Visible = False ' Logic screen settings Sheets("Logic").Visible = False Sheets("Payroll_Entry").Select End Sub '************************************************* ************************** '** SIT F U N C T I O N '************************************************* ************************** Function SIT(Employee, AdjGross) If IsError(Employee) Then SIT = 0: Exit Function ConvFactor = PayFrequencyAnnualConvFactor(Employee) AnnualGross = (AdjGross * ConvFactor) - _ (Range("Employee_List!A5").Offset(Employee, EL_STATE_ALLOW - 1) * 2250) If Range("Employee_List!A5").Offset(Employee, EL_STATUS - 1) = "Single" Then If AnnualGross <= 3000 Then Table = 0 ElseIf AnnualGross <= 18000 Then Table = (AnnualGross - 3000) * 0.035 ElseIf AnnualGross <= 33000 Then Table = 525 + ((AnnualGross - 18000) * 0.0625) Else Table = 1462.5 + ((AnnualGross - 33000) * 0.0645) End If Else If AnnualGross <= 6000 Then Table = 0 ElseIf AnnualGross <= 36000 Then Table = (AnnualGross - 6000) * 0.035 ElseIf AnnualGross <= 66000 Then Table = 1050 + ((AnnualGross - 36000) * 0.0625) Else Table = 2925 + ((AnnualGross - 66000) * 0.0645) End If End If SIT = -Application.Round((Table / ConvFactor) + _ Range("Employee_List!A5").Offset(Employee, EL_EXTRA_SIT - 1), 2) End Function '************************************************* ************************** '** SortByCustomer P R O C E D U R E '************************************************* ************************** Sub SortByCustomer() Application.ScreenUpdating = False Sheets("Payroll_Entry").Select Sheets("Payroll_Entry").Unprotect Range("PE_Data").Sort Key1:=Range("L8"), Order1:=xlAscending, Key2:=Range _ ("F8"), Order2:=xlAscending, Key3:=Range("G8"), Order3:=xlAscending, _ Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom Sheets("Payroll_Entry").Protect DrawingObjects:=True, Contents:=True, _ Scenarios:=True SendKeys ("^{Home}") End Sub '************************************************* ************************** '** SortByBillRate P R O C E D U R E '************************************************* ************************** Sub SortByBillRate() Application.ScreenUpdating = False Sheets("Payroll_Entry").Select Sheets("Payroll_Entry").Unprotect Range("PE_Data").Sort Key1:=Range("K8"), Order1:=xlAscending, Key2:=Range _ ("L8"), Order2:=xlAscending, Key3:=Range("G8"), Order3:=xlAscending, _ Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom Sheets("Payroll_Entry").Protect DrawingObjects:=True, Contents:=True, _ Scenarios:=True SendKeys ("^{Home}") End Sub '************************************************* ************************** '** SortByDate P R O C E D U R E '************************************************* ************************** Sub SortByDate() Application.ScreenUpdating = False Sheets("Payroll_Entry").Select Sheets("Payroll_Entry").Unprotect Range("PE_Data").Sort Key1:=Range("F8"), Order1:=xlAscending, Key2:=Range _ ("C8"), Order2:=xlAscending, Key3:=Range("G8"), Order3:=xlAscending, _ Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom Sheets("Payroll_Entry").Protect DrawingObjects:=True, Contents:=True, _ Scenarios:=True SendKeys ("^{Home}") End Sub '************************************************* ************************** '** SortByDepartment P R O C E D U R E '************************************************* ************************** Sub SortByDepartment() Application.ScreenUpdating = False Sheets("Payroll_Entry").Select Sheets("Payroll_Entry").Unprotect Range("PE_Data").Sort Key1:=Range("D8"), Order1:=xlAscending, Key2:=Range _ ("L8"), Order2:=xlAscending, Key3:=Range("F8"), Order3:=xlAscending, _ Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom Sheets("Payroll_Entry").Protect DrawingObjects:=True, Contents:=True, _ Scenarios:=True SendKeys ("^{Home}") End Sub |
#5
|
|||
|
|||
RE: Macros problem with XP
Third and final part:
'************************************************* ************************** '** SortByEmployee P R O C E D U R E '************************************************* ************************** 'Sub SortByEmployee() 'Application.ScreenUpdating = False 'Sheets("Payroll_Entry").Select 'Sheets("Payroll_Entry").Unprotect 'Range("PE_Data").Sort Key1:=Range("C8"), Order1:=xlAscending, Key2:=Range _ ("G8"), Order2:=xlAscending, Key3:=Range("D8"), Order3:=xlAscending, _ Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom 'Sheets("Payroll_Entry").Protect DrawingObjects:=True, Contents:=True, _ Scenarios:=True 'SendKeys ("^{Home}") 'End Sub '************************************************* ************************** '** SortByPayRate P R O C E D U R E '************************************************* ************************** Sub SortByPayRate() Application.ScreenUpdating = False Sheets("Payroll_Entry").Select Sheets("Payroll_Entry").Unprotect Range("PE_Data").Sort Key1:=Range("J8"), Order1:=xlAscending, Key2:=Range _ ("C8"), Order2:=xlAscending, Key3:=Range("G8"), Order3:=xlAscending, _ Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom Sheets("Payroll_Entry").Protect DrawingObjects:=True, Contents:=True, _ Scenarios:=True SendKeys ("^{Home}") End Sub '************************************************* ************************** '** SUI F U N C T I O N '************************************************* ************************** Function SUI(Employee, AdjGross) If IsError(Employee) Then SUI = 0: Exit Function EmpYtdGross = Range("Employee_List!A5").Offset(Employee, EL_YTD_GROSS - 1) If (AdjGross + EmpYtdGross) > 8000 Then If EmpYtdGross > 8000 Then SUI = 0 Else SUI = Application.Round((8000 - EmpYtdGross) * 0.0352, 2) End If Else SUI = Application.Round(AdjGross * 0.0352, 2) End If End Function '************************************************* ************************** '** PSLookup F U N C T I O N '************************************************* ************************** Function PSLookup(LookupText, EmployeeRow, LookupRow) PSLookup = Application.HLookup(LookupText, Range("PS_TData"), _ EmployeeRow + EmployeeRow + LookupRow, False) If IsError(PSLookup) Then PSLookup = 0 End Function '************************************************* ************************** '** UpdateCustomerList P R O C E D U R E '************************************************* ************************** Sub UpdateCustomerList() RPointer = CL_DATA_ROW Application.Calculation = xlManual Range("S_Function").Formula = "Updating Customer List" Range("S_Counter").Formula = 0 Sheets("Status").Visible = True Sheets("Status").Select Application.ScreenUpdating = False On Error GoTo ErrorHandler ' Enable error-handling routine. Channel = Application.DDEInitiate("PeachW", COMPANY) DDEPoke Channel, "Password", Range("PWord") PAWData = DDERequest(Channel, "file=customer,first,field=key,field=name,field=ty pe,field=custom1,field=inactive") ' PAWData = DDERequest(Channel, "file=customer,first,field=key,field=name,field=re salenumber,field=contact,field=inactive") NoFields = UBound(PAWData) - 1 Sheets("Customer_List").Select Sheets("Customer_List").Unprotect Sheets("Customer_List").Range(Rows(RPointer), Rows(2000)).Delete Shift:=xlUp Sheets("Status").Select Application.ScreenUpdating = True While Not IsError(PAWData) If PAWData(NoFields + 1) = "N" Then Range("S_Counter").Formula = RPointer - 5 Worksheets("Customer_List").Cells(RPointer, 1).Formula = RPointer - 5 For CPointer = 1 To NoFields Worksheets("Customer_List").Cells(RPointer, CPointer + 1).Formula = _ PAWData(CPointer) Next CPointer RPointer = RPointer + 1 End If PAWData = DDERequest(Channel, "file=customer,next,field=key,field=name,field=typ e,field=custom1,field=inactive") ' PAWData = DDERequest(Channel, "file=customer,next,field=key,field=name,field=res alenumber,field=contact,field=inactive") Wend Application.ScreenUpdating = False Application.DDETerminate (Channel) RPointer = RPointer - 1 Sheets("Customer_List").Select ActiveSheet.Range(Cells(6, 1), Cells(RPointer, 5)).Interior.ColorIndex = 14 ActiveSheet.Range(Cells(6, 1), Cells(RPointer, 5)). _ Borders(xlBottom).Weight = xlHairline ActiveSheet.Range(Cells(6, 1), Cells(RPointer, 5)).BorderAround Weight:=xlThick ActiveSheet.Range(Cells(6, 2), Cells(RPointer, 2)).Interior.ColorIndex = 8 Names.Add Name:="CL_Data", RefersToR1C1:=Sheets("Customer_List") _ .Range(Cells(6, 2), Cells(RPointer, 5)) ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True Sheets("Status").Visible = False Application.Calculation = xlAutomatic SendKeys ("^{Home}") Exit Sub ' Exit Sub before error handler. ErrorHandler: ' Error-handling routine. Application.Calculation = xlAutomatic Sheets("Status").Visible = False Sheets("Customer_List").Select MsgBox ("The Peachtree accounting program must be running in the background before running this function. Start Peachtree then try again.") End End Sub '************************************************* ************************** '** UpdateDeptSum P R O C E D U R E '************************************************* ************************** Sub UpdateDeptSum() Application.ScreenUpdating = False Sheets("Dept_Sum").Select ActiveSheet.Unprotect ActiveSheet.PivotTables("DS_PT").RefreshTable ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True SendKeys ("^{Home}") End Sub '************************************************* ************************** '** UpdatePayrollEntry F U N C T I O N '************************************************* ************************** Sub UpdatePayrollEntry() Application.ScreenUpdating = False Application.Calculation = xlManual Sheets("Payroll_Entry").Unprotect RPointer = Range("Payroll_Entry!A7").End(xlDown).Row Range("PE_Formula").EntireRow.Hidden = False Range("Payroll_Entry!B5").Copy ActiveSheet.Paste destination:=Range(Cells(8, 2), Cells(RPointer, 2)) Range("Payroll_Entry!D5").Copy ActiveSheet.Paste destination:=Range(Cells(8, 4), Cells(RPointer, 4)) Range("Payroll_Entry!I5").Copy ActiveSheet.Paste destination:=Range(Cells(8, 9), Cells(RPointer, 9)) Range("Payroll_Entry!J5").Copy ActiveSheet.Paste destination:=Range(Cells(8, 10), Cells(RPointer, 10)) Range("Payroll_Entry!K5").Copy ActiveSheet.Paste destination:=Range(Cells(8, 11), Cells(RPointer, 11)) Range("Payroll_Entry!M5").Copy ActiveSheet.Paste destination:=Range(Cells(8, 13), Cells(RPointer, 13)) Application.Calculation = xlAutomatic Range("PE_Formula").EntireRow.Hidden = True ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True SendKeys ("^{Home}") End Sub '************************************************* ************************** '** UpdateEmployeeList P R O C E D U R E '************************************************* ************************** Sub UpdateEmployeeList() RPointer = EL_DATA_ROW Application.Calculation = xlManual Range("S_Function").Formula = "Updating Employee List" Range("S_Counter").Formula = 0 Sheets("Status").Visible = True Sheets("Status").Select Application.ScreenUpdating = False On Error GoTo ErrorHandler ' Enable error-handling routine. Channel = Application.DDEInitiate("PeachW", COMPANY) DDEPoke Channel, "Password", Range("PWord") PAWData = DDERequest(Channel, "file=employee,first,field=key,field=name,field=fi lingstatus,field=frequency,field=allowances,field= extrafit,field=stateallowances,field=gross,ytd,fie ld=custom1, field=stateadditional, field=inactive") NoFields = UBound(PAWData) - 1 Sheets("Employee_List").Select Sheets("Employee_List").Unprotect Sheets("Employee_List").Range(Rows(RPointer), Rows(999)).Delete Shift:=xlUp Sheets("Status").Select Application.ScreenUpdating = True While Not IsError(PAWData) If PAWData(NoFields + 1) = "N" Then Range("S_Counter").Formula = RPointer - 5 Worksheets("Employee_List").Cells(RPointer, 1).Formula = RPointer - 5 For CPointer = 1 To NoFields Worksheets("Employee_List").Cells(RPointer, CPointer + 1).Formula = _ PAWData(CPointer) Next CPointer RPointer = RPointer + 1 End If PAWData = DDERequest(Channel, "file=employee,next,field=key,field=name,field=fil ingstatus,field=frequency,field=allowances,field=e xtrafit,field=stateallowances,field=gross,ytd,fiel d=custom1,field=stateadditional,field=inactive") Wend Application.ScreenUpdating = False Application.DDETerminate (Channel) RPointer = RPointer - 1 Sheets("Employee_List").Select ActiveSheet.Range(Cells(6, 1), Cells(RPointer, 11)).Interior.ColorIndex = 14 ActiveSheet.Range(Cells(6, 1), Cells(RPointer, 11)) _ .Borders(xlBottom).Weight = xlHairline ActiveSheet.Range(Cells(6, 1), Cells(RPointer, 11)).BorderAround Weight:=xlThick ActiveSheet.Range(Cells(6, 2), Cells(RPointer, 2)).Interior.ColorIndex = 8 Names.Add Name:="EL_Data", RefersToR1C1:=Sheets("Employee_List") _ .Range(Cells(6, 2), Cells(RPointer, 11)) Names.Add Name:="EL_ID", RefersToR1C1:=Sheets("Employee_List") _ .Range(Cells(6, 2), Cells(RPointer, 2)) ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True Sheets("Status").Visible = False Application.Calculation = xlAutomatic SendKeys ("^{Home}") Exit Sub ' Exit Sub before error handler. ErrorHandler: ' Error-handling routine. Application.Calculation = xlAutomatic Sheets("Status").Visible = False Sheets("Employee_List").Select MsgBox ("The Peachtree accounting program must be running in the background before running this function. Start Peachtree then try again.") End End Sub '************************************************* ************************** '** UpdatePayrollCalc P R O C E D U R E '************************************************* ************************** Sub UpdatePayrollCalc() Application.ScreenUpdating = False ' If MsgBox("Do you also want to update the Customer & Employee list?", 4) = 6 Then ' UpdateCustomerList UpdateEmployeeList ' End If UpdatePayrollSum RPointer = Range("Payroll_Sum!A:A").Find("Total Sum of Hours").Row + 1 Sheets("Payroll_Calc").Select ActiveSheet.Unprotect Range(Rows(PC_DATA_ROW), Rows(999)).Delete Shift:=xlUp Range("PC_Formula").EntireRow.Hidden = False Range("PC_Formula").Copy Range(Rows(PC_DATA_ROW), Rows(RPointer)).Insert Shift:=xlDown Range("PC_Formula").EntireRow.Hidden = True Range("Payroll_Calc!C8").Formula = "=COUNTIF(C10:C" & Format(RPointer _ ) & "," & Chr(34) & "*" & Chr(34) & ")" Range("Payroll_Calc!D8").Formula = "=SUMIF(B10:B" & Format(RPointer _ ) & "," & Chr(34) & "*" & Chr(34) & ",D10:D" & Format(RPointer) & ")" Range("Payroll_Calc!E8").Formula = "=SUMIF(B10:B" & Format(RPointer _ ) & "," & Chr(34) & "*" & Chr(34) & ",E10:E" & Format(RPointer) & ")" Range("Payroll_Calc!F8").Formula = "=SUMIF(B10:B" & Format(RPointer _ ) & "," & Chr(34) & "*" & Chr(34) & ",F10:F" & Format(RPointer) & ")" Range("Payroll_Calc!G8").Formula = "=SUMIF($B10:$B" & Format(RPointer _ ) & "," & Chr(34) & "*" & Chr(34) & ",G10:G" & Format(RPointer) & ")" Range("Payroll_Calc!AK8").Formula = "=SUMIF(B10:B" & Format(RPointer _ ) & "," & Chr(34) & "*" & Chr(34) & ",AK10:AK" & Format(RPointer) & ")" Range("Payroll_Calc!G8").Copy ActiveSheet.Paste destination:=Range("Payroll_Calc!H8:AJ8") ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True SendKeys ("^{Home}") End Sub '************************************************* ************************** '** UpdatePayrollSum P R O C E D U R E '************************************************* ************************** Sub UpdatePayrollSum() Application.ScreenUpdating = False 'SortByEmployee Sheets("Payroll_Sum").Select ActiveSheet.Unprotect ActiveSheet.PivotTables("PS_PT").RefreshTable On Error Resume Next ActiveSheet.PivotTables("PS_PT").PivotFields("Emp. ID") _ .PivotItems("(blank)").Visible = False ActiveSheet.PivotTables("PS_PT").PivotFields("Emp. Name") _ .PivotItems("(blank)").Visible = False ActiveSheet.PivotTables("PS_PT").PivotFields("Emp. Name") _ .PivotItems("#N/A").Visible = False On Error GoTo 0 CPointer = Range("Payroll_Sum!6:6").Find("Grand Total").Column RPointer = Range("Payroll_Sum!A:A").Find("Total Sum of Hours").Row + 1 Names.Add Name:="PS_TData", RefersToR1C1:= _ Sheets("Payroll_Sum").Range(Cells(6, 4), Cells(RPointer, CPointer)) ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True SendKeys ("^{Home}") End Sub |
#6
|
|||
|
|||
RE: Macros problem with XP
Thanks for posting the code: it is very long and complex! I can only make a
few observations since, firstly, I don't have the time to do extensive debugging, secondly, I don't have any way to test the setup (I don't have or know much about Peachtree) and finally, the use of Dynamic Data Exchange (DDE) is something I am only slightly experienced with. But I can perhaps provide some info to help your IT staff work on this. The VBA code here is using DDE to access Peachtree. DDE is a way for applications to share data. Here is one example of where the code invokes DDE, from the GenerateInvoice function (there are similar instances in most of the "GenerateXxxx" functions): On Error GoTo ErrorHandler ' Enable error-handling routine. ' Channel = Application.DDEInitiate("PeachW", COMPANY) ' DDEPoke Channel, "Password", Range("PWord") Then the error handler gives the error message you are seeing: ErrorHandler: ' Error-handling routine. Sheets("Status").Visible = False Sheets("Payroll_Calc").Select MsgBox ("The Peachtree accounting program must be running in the background before running this function. Start Peachtree then try again.") Now, in DDE you first establish communication with the other application by setting up a channel - that is what the Channel = Application.DDEInitiate() line is trying to do. Then it uses DDEPoke statements to send information or instructions to the other app, or a DDERequest to get data from it. It is erroring out somewhere in that process - I suspect it is in the DDEInitiate statement. Don't know what may have changed in XP that would affect this, or if maybe it is something different in the machine setup that makes it not find Peachtree when it looks for it. For example, the DDEInitiate refers to Peachtree only as "PeachW" - no path, no extension - does the XL setup recognize this? Is Peachtree in the default file path? If that changed, perhaps that is why it can't find it. For more info, here is a link to the DDE section of the MSDN library http://msdn.microsoft.com/library/de...DEInitiate.asp Sorry I can't do more, hope this contributes at least something to help others find the solution! |
#7
|
|||
|
|||
Re: Macros problem with XP
Maybe "Ignore Other apps" on Tools->general is checked. This is an DDE
blocking feature of Excel Dm Unseen. |
#8
|
|||
|
|||
I have the same problem. Did you found a solution?
Thanks, Patricio |
#9
|
|||
|
|||
Solution
Our problem was that the folder names of the path, where was the Peachtree data (In the win2003 server) had more than eight characters, then the DDE connection failed.
|
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Macros & Passwords | paulrm906 | Excel | 0 | 03-04-2006 01:30 AM |
Self Help Books for Macros? | KRB | Excel | 0 | 11-22-2005 01:33 PM |