Hello,
Our account specialist is using macro for importing and exporting files for years. She is getting an type mismatch error after windows 10 and office 2016 upgrade according to her. I tried to change datatype but still getting a same error message. Do you have any idea to solve this kind of issue? I am also attaching my xlsm file and also xls file.
I attached vba code here.
' v.2 10/29/2002 ' used M for filespec
' Locked cells
' isnumeric validity check for phone number
' v.3 11/1/2002 three period type
' import function added
' v.4 11/19/2002 Output 00's instead of blanks for dates
' Output 000 for undetermined status
' Add one to record count in header record
' v.5 11/21/2002 Output spaces instead of zeros for dates
' v1.0 12/4/2002 Added ad to picklist page, fixed spelling in A12
' v1.1 12/12/2002 Remove address requirement
' v1.2 12/27/2002 Problem with pull-down in A49
' v1.3 1/8/2003 Import fields in wrong order
' v1.4 2/13/03 replace future active '000' with ' '
' 10/15/2012 rch - added code to allow export file location, changed font to white to hide job category and job classification data
Function Validate() As Boolean
On Error GoTo Validate_Error
Dim rgEmployeeData As Range
Dim rgEmployerData As Range
Dim rgJobCategories As Range
Dim rgJobClassification As Range
Set rgEmployeeData = Range("Employeedata")
Set rgEmployerData = Range("employerdata")
Set rgJobCategories = Range("jobcategories")
Set rgJobClassifications = Range("jobclassifications")
Validate = True
' check the employer code is numeric
If Not IsNumeric(rgEmployerData.Cells(1, 3).Value) Then
MsgBox "Invalid Employer code.", vbCritical, "Entry error"
Validate = False
End If
' check the file start code is 3 characters
If Len(Trim(rgEmployerData.Cells(2, 3).Value)) <> 3 Then
MsgBox "Invalid File Start Code.", vbCritical, "Entry Error"
Validate = False
End If
' check monthly/bi-weekly code is a M, B1 or B2
If Not IsNumeric(rgEmployerData.Cells(5, 3).Value) Or rgEmployerData.Cells(5, 3).Value < 1 Or rgEmployerData.Cells(5, 3).Value > 3 Then
MsgBox "Invalid Payroll cycle", vbCritical, "Entry error"
Validate = False
End If
' check File Creation is a date
If Not IsDate(rgEmployerData.Cells(6, 3).Value) Then
MsgBox "Invalid Period Ending Date", vbCritical, "Entry Error"
Validate = False
End If
For I = 1 To 500
' if this record as a SSN or last name check it. Otherwise skip it.
If Trim(rgEmployeeData.Cells(I, 3).Value) <> "" Or Trim(rgEmployeeData.Cells(I, 6).Value) <> "" Then
' check for valid SSN
If Len(rgEmployeeData.Cells(I, 3).Value) <> 9 Then
MsgBox "Invalid Social Security Number for " & Trim(rgEmployeeData.Cells(I, 4).Value) & " " & Trim(rgEmployeeData.Cells(I, 6).Value), vbCritical, "Entry Error"
Validate = False
Exit Function
End If
If Not IsNumeric(rgEmployeeData.Cells(I, 3).Value) Then
MsgBox "Invalid Social Security Number for " & Trim(rgEmployeeData.Cells(I, 4).Value) & " " & Trim(rgEmployeeData.Cells(I, 6).Value), vbCritical, "Entry Error"
Validate = False
Exit Function
End If
' check for valid first
If Len(rgEmployeeData.Cells(I, 4).Value) < 1 Then
MsgBox "Invalid first name for " & rgEmployeeData.Cells(I, 3).Value, vbCritical, "Entry Error"
Validate = False
Exit Function
End If
' check for valid last
If Len(rgEmployeeData.Cells(I, 6).Value) < 1 Then
MsgBox "Invalid last name for " & rgEmployeeData.Cells(I, 3).Value, vbCritical, "Entry Error"
Validate = False
Exit Function
End If
' check for valid sex
If UCase(Left(rgEmployeeData.Cells(I, 8).Value, 1)) = "M" Or UCase(Left(rgEmployeeData.Cells(I, 8).Value, 1)) = "F" Then
Else
MsgBox "Invalid sex for " & rgEmployeeData.Cells(I, 4).Value & " " & rgEmployeeData.Cells(I, 6).Value, vbCritical, "Entry Error"
Validate = False
Exit Function
End If
' check the birth date for validity
If Not IsDate(rgEmployeeData.Cells(I, 9).Value) And Not rgEmployeeData.Cells(I, 9).Value = "" Then
MsgBox "Invalid birth date for " & Trim(rgEmployeeData.Cells(I, 4).Value) & " " & Trim(rgEmployeeData.Cells(I, 6).Value), vbCritical, "Entry Error"
Validate = False
Exit Function
End If
' check for valid address
' If Len(rgEmployeeData.Cells(I, 10).Value) < 1 Then
' MsgBox "Invalid address for " & rgEmployeeData.Cells(I, 4).Value & " " & rgEmployeeData.Cells(I, 6).Value, vbCritical, "Entry Error"
' Validate = False
' Exit Function
' End If
' check for valid city
If Len(rgEmployeeData.Cells(I, 13).Value) < 1 Then
MsgBox "Invalid city for " & rgEmployeeData.Cells(I, 4).Value & " " & rgEmployeeData.Cells(I, 6).Value, vbCritical, "Entry Error"
Validate = False
Exit Function
End If
' check for valid state
If Len(rgEmployeeData.Cells(I, 14).Value) <> 2 Then
MsgBox "Invalid state for " & rgEmployeeData.Cells(I, 4).Value & " " & rgEmployeeData.Cells(I, 6).Value, vbCritical, "Entry Error"
Validate = False
Exit Function
End If
' check for valid zip
If Len(rgEmployeeData.Cells(I, 15).Value) = 5 Or Len(rgEmployeeData.Cells(I, 15).Value) = 9 Then
Else
MsgBox "Invalid zip for " & rgEmployeeData.Cells(I, 4).Value & " " & rgEmployeeData.Cells(I, 6).Value, vbCritical, "Entry Error"
Validate = False
Exit Function
End If
' check for valid phone
If Not IsNumeric(rgEmployeeData(I, 17).Value) Then
MsgBox "Invalid phone for " & rgEmployeeData.Cells(I, 4).Value & " " & rgEmployeeData.Cells(I, 6).Value & " (Numbers only.)", vbCritical, "Entry Error"
Validate = False
Exit Function
End If
If Len(rgEmployeeData.Cells(I, 17).Value) > 10 Then
MsgBox "Invalid phone for " & rgEmployeeData.Cells(I, 4).Value & " " & rgEmployeeData.Cells(I, 6).Value & " (Exceeds 10 chars.)", vbCritical, "Entry Error"
Validate = False
Exit Function
End If
' check the hire date for validity
If Not IsDate(rgEmployeeData.Cells(I, 19).Value) And Not rgEmployeeData.Cells(I, 19).Value = "" Then
MsgBox "Invalid Hire date for " & Trim(rgEmployeeData.Cells(I, 4).Value) & " " & Trim(rgEmployeeData.Cells(I, 6).Value), vbCritical, "Entry Error"
Validate = False
Exit Function
End If
' check termination date
If Not IsDate(rgEmployeeData.Cells(I, 20).Value) And Not rgEmployeeData.Cells(I, 20) = "" Then
MsgBox "Invalid Termination date for " & Trim(rgEmployeeData.Cells(I, 4).Value) & " " & Trim(rgEmployeeData.Cells(I, 6).Value), vbCritical, "Entry Error"
Validate = False
Exit Function
End If
' check Future Status date
If rgEmployeeData.Cells(I, 21).Value <> "" Then
If Not IsDate(rgEmployeeData.Cells(I, 21).Value) Then
MsgBox "Invalid future date for " & Trim(rgEmployeeData.Cells(I, 4).Value) & " " & Trim(rgEmployeeData.Cells(I, 6).Value), vbCritical, "Entry Error"
Validate = False
Exit Function
End If
End If
' check for proper active/term status
If rgEmployeeData.Cells(I, 21).Value <> "" Then
If UCase(Left(rgEmployeeData.Cells(I, 22).Value, 1)) = "A" Or UCase(Left(rgEmployeeData.Cells(I, 8).Value, 1)) = "T" Then
Else
MsgBox "Invalid Active/Term for " & Trim(rgEmployeeData.Cells(I, 4).Value) & " " & Trim(rgEmployeeData.Cells(I, 6).Value), vbCritical, "Entry Error"
Validate = False
Exit Function
End If
End If
' check for proper FTE %
If Not IsNumeric(rgEmployeeData.Cells(I, 23).Value) Then
MsgBox "Invalid FTE % for " & Trim(rgEmployeeData.Cells(I, 4).Value) & " " & Trim(rgEmployeeData.Cells(I, 6).Value), vbCritical, "Entry Error"
Validate = False
Exit Function
End If
If rgEmployeeData.Cells(I, 23).Value > 1 Or rgEmployeeData.Cells(I, 23).Value < 0 Then
MsgBox "Invalid FTE % for " & Trim(rgEmployeeData.Cells(I, 4).Value) & " " & Trim(rgEmployeeData.Cells(I, 6).Value), vbCritical, "Entry Error"
Validate = False
Exit Function
End If
v = RecordCount
End If
Next I
Exit Function
Validate_Error:
MsgBox Err.Description, vbCritical, "Validate"
End Function
Function RecordCount() As Integer
' this function will count the number of records ready to be transmitted
On Error GoTo RecordCount_Error
Dim rgEmployeeData As Range
Dim rgEmployerData As Range
Dim R As Integer
Set rgEmployeeData = Range("Employeedata")
Set rgEmployerData = Range("employerdata")
RecordCount = 0
For R = 1 To 500
If Trim(rgEmployeeData.Cells(R, 3).Value) <> "" Or Trim(rgEmployeeData.Cells(R, 6).Value) <> "" Then
RecordCount = RecordCount + 1
End If
Next R
' compare record count
If RecordCount <> rgEmployerData.Cells(7, 3).Value Then
MsgBox "Updating Record count to: " & RecordCount, vbInformation, "Updating record count"
rgEmployerData.Cells(7, 3) = RecordCount
End If
Exit Function
RecordCount_Error:
MsgBox Err.Description, vbCritical, "RecordCount"
End Function
Sub cmdExport()
On Error GoTo cmdExport_Error
'
'
Dim rgEmployeeData As Range
Dim rgEmployerData As Range
Dim rgJobCategories As Range
Dim rgJobClassification As Range
Dim R As Long, C As Long
Dim FileSpec As String
Dim PLine As String
If Not Validate Then
Exit Sub
End If
Set rgEmployeeData = Range("Employeedata")
Set rgEmployerData = Range("employerdata")
Set rgJobCategories = Range("jobcategories")
Set rgJobClassifications = Range("jobclassifications")
On Error GoTo File_Error
If Right(rgEmployerData.Cells(9, 3).Value, 1) <> "\" Then
rgEmployerData.Cells(9, 3).Value = rgEmployerData.Cells(9, 3).Value & "\"
End If
FileSpec = rgEmployerData.Cells(9, 3).Value & rgEmployerData.Cells(2, 3).Value & Format(rgEmployerData.Cells(6, 3).Value, "MM") & Right(Format(rgEmployerData.Cells(6, 3).Value, "yyyy"), 4) & "M.txt"
Open FileSpec For Input As #1
Close #1
v = MsgBox("The file " & FileSpec & " already exits.", vbOKCancel)
If v = vbCancel Then
Exit Sub
End If
NewFile:
Open FileSpec For Output As #1
On Error GoTo cmdExport_Error
Set rgEmployeeData = Range("Employeedata")
Set rgEmployerData = Range("employerdata")
Set rgJobCategories = Range("jobcategories")
Set rgJobClassifications = Range("jobclassifications")
' first send the header record
' header id
PLine = Format(Date, "mmdd")
' employer code
PLine = PLine & Format(rgEmployerData.Cells(1, 3).Value, "0000000")
' record cound
' add 1 to the record count for the header record
PLine = PLine & Format(rgEmployerData.Cells(7, 3).Value, "00000")
' File creation date period
PLine = PLine & Format(rgEmployerData.Cells(6, 3).Value, "mmddyyyy")
Print #1, PLine
For R = 1 To 500
' if this record has a SSN or last name check it. Otherwise skip it.
If Trim(rgEmployeeData.Cells(R, 3).Value) <> "" Or Trim(rgEmployeeData.Cells(R, 6).Value) <> "" Then
' header id
PLine = Format(Format(Date, "mmdd"), "0000")
' employer code
PLine = PLine & Format(rgEmployerData.Cells(1, 3).Value, "0000000")
' billing entity code
PLine = PLine & Format(rgEmployerData.Cells(4, 3).Value, "0000")
' agreement code
PLine = PLine & Format(rgEmployerData.Cells(5, 3), "000000")
' site code
PLine = PLine & " "
' ssn
PLine = PLine & Format(rgEmployeeData.Cells(R, 3), "000000000")
' last name
PLine = PLine & Left((rgEmployeeData.Cells(R, 6).Value & Space(50)), 50)
' first name
PLine = PLine & Left((rgEmployeeData.Cells(R, 4).Value & Space(50)), 50)
' middle
PLine = PLine & Left((rgEmployeeData.Cells(R, 5).Value & Space(50)), 50)
' suffix
PLine = PLine & Left((rgEmployeeData.Cells(R, 7).Value & Space(3)), 3)
' sex
PLine = PLine & UCase(Left((rgEmployeeData.Cells(R, 8).Value & Space(3)), 1))
' birthdate
PLine = PLine & Format(rgEmployeeData.Cells(R, 9).Value, "mmddyyyy")
' address 1
PLine = PLine & Left((rgEmployeeData.Cells(R, 10).Value & Space(50)), 50)
' address 2
PLine = PLine & Left((rgEmployeeData.Cells(R, 11).Value & Space(50)), 50)
' address 3
PLine = PLine & Left((rgEmployeeData.Cells(R, 12).Value & Space(50)), 50)
' city
PLine = PLine & Left((rgEmployeeData.Cells(R, 13).Value & Space(50)), 50)
' state
PLine = PLine & Left((rgEmployeeData.Cells(R, 14).Value & Space(2)), 2)
' zip
PLine = PLine & Left((rgEmployeeData.Cells(R, 15).Value & Space(9)), 9)
' country
PLine = PLine & Left((rgEmployeeData.Cells(R, 16).Value & Space(3)), 3)
' phone
PLine = PLine & Left((rgEmployeeData.Cells(R, 17).Value & Space(10)), 10)
' e-mail
PLine = PLine & Left((rgEmployeeData.Cells(R, 18).Value & Space(30)), 30)
' job category
Select Case rgEmployeeData.Cells(R, 1)
Case 1
PLine = PLine & Left(rgJobCategories.Cells(1, 1) + Space(2), 2)
Case 2
PLine = PLine & Left(rgJobCategories.Cells(2, 1) + Space(2), 2)
Case 3
PLine = PLine & Left(rgJobCategories.Cells(3, 1) + Space(2), 2)
Case 4
PLine = PLine & Left(rgJobCategories.Cells(4, 1) + Space(2), 2)
Case 5
PLine = PLine & Left(rgJobCategories.Cells(5, 1) + Space(2), 2)
Case 6
PLine = PLine & Left(rgJobCategories.Cells(6, 1) + Space(2), 2)
Case 7
PLine = PLine & Left(rgJobCategories.Cells(7, 1) + Space(2), 2)
Case 8
PLine = PLine & Left(rgJobCategories.Cells(8, 1) + Space(2), 2)
Case Else
MsgBox "You have entered an invalid Job Category on row " & R & ".", vbCritical, "Invalid data"
Exit Sub
End Select
' job classification
Select Case rgEmployeeData.Cells(R, 2)
Case 1
PLine = PLine & Left(rgJobClassifications.Cells(1, 1) + Space(2), 2)
Case 2
PLine = PLine & Left(rgJobClassifications.Cells(2, 1) + Space(2), 2)
Case 3
PLine = PLine & Left(rgJobClassifications.Cells(3, 1) + Space(2), 2)
Case 4
PLine = PLine & Left(rgJobClassifications.Cells(4, 1) + Space(2), 2)
Case Else
MsgBox "You have entered an invalid Job Category on row " & R & ".", vbCritical, "Invalid data"
Exit Sub
End Select
' hire date
If rgEmployeeData.Cells(R, 19).Value = "" Then
PLine = PLine & Space(8)
Else
PLine = PLine & Format(rgEmployeeData.Cells(R, 19).Value, "mmddyyyy")
End If
' termination date
If rgEmployeeData.Cells(R, 20).Value = "" Then
PLine = PLine & Space(8)
Else
PLine = PLine & Format(rgEmployeeData.Cells(R, 20).Value, "mmddyyyy")
End If
' future status date
If rgEmployeeData.Cells(R, 21).Value = "" Then
PLine = PLine & Space(8)
Else
PLine = PLine & Format(rgEmployeeData.Cells(R, 21).Value, "mmddyyyy")
End If
' future status
Select Case UCase(Left(rgEmployeeData.Cells(R, 22), 1))
Case "A"
PLine = PLine & "ACT"
Case "T"
PLine = PLine & "TRM"
Case Else
PLine = PLine & " "
End Select
' fte percentage
PLine = PLine & Format(rgEmployeeData.Cells(R, 23).Value * 100, "000")
Print #1, PLine
End If
Next R
Close #1
MsgBox "Export file: " & FileSpec & " created.", vbInformation, "Success"
Exit Sub
cmdExport_Error:
MsgBox Err.Description, vbCritical, "cmdExport"
Exit Sub
File_Error:
'MsgBox Err.Number
If Err.Number = 53 Then ' file not found
Resume NewFile:
Else
MsgBox Err.Number, Err.Description, vbc, "cmdExport"
Resume Next
End If
End Sub
Sub Showform()
Load MemberForm
MemberForm.Show
End Sub
Sub Import()
On Error GoTo Import_Error
'
'
Dim rgEmployeeData As Range
Dim rgEmployerData As Range
Dim rgJobCategories As Range
Dim rgJobClassification As Range
Dim R As Long, C As Long
Dim FileSpec As String
Dim PLine As String
Dim JobCategory, JobClassifiction, SSN, FName, MName, Lname, Suffix, Active, Gross, Member, Total, FTE, HireDate, TerminationDate As String
Dim Inrec As String
Set rgEmployeeData = Range("Employeedata")
Set rgEmployerData = Range("employerdata")
Set rgJobCategories = Range("jobcategories")
Set rgJobClassifications = Range("jobclassifications")
' clear the rows
For R = 1 To 2
For C = 1 To 2
rgEmployeeData.Cells(R, C).Value = ""
Next C
Next R
R = 0
On Error GoTo File_Error
FileSpec = rgEmployerData.Cells(8, 3).Value
Open FileSpec For Input As #1
On Error GoTo Import_Error
Do While Not EOF(1)
Line Input #1, Inrec
R = R + 1
' job category
x = UCase(Trim(ParseInrec(Inrec, 1)))
Select Case UCase(Trim(ParseInrec(Inrec, 17)))
Case "R"
rgEmployeeData.Cells(R, 1) = 1
Case "RT"
rgEmployeeData.Cells(R, 1) = 2
Case "RP"
rgEmployeeData.Cells(R, 1) = 3
Case "AP"
rgEmployeeData.Cells(R, 1) = 4
Case "RE"
rgEmployeeData.Cells(R, 1) = 5
Case "RW"
rgEmployeeData.Cells(R, 1) = 6
Case "LW"
rgEmployeeData.Cells(R, 1) = 7
Case "PT"
rgEmployeeData.Cells(R, 1) = 8
Case Else
MsgBox "Invalid Job Category in input file row " & R, vbCritical, "Import Error"
Exit Sub
End Select
' job classification
Select Case UCase(Trim(ParseInrec(Inrec, 18)))
Case "AD"
rgEmployeeData.Cells(R, 2) = 1
Case "TE"
rgEmployeeData.Cells(R, 2) = 2
Case "OC"
rgEmployeeData.Cells(R, 2) = 3
Case "NC"
rgEmployeeData.Cells(R, 2) = 4
Case Else
MsgBox "Invalid Job Classification in input file row " & R, vbCritical, "Import Error"
Exit Sub
End Select
' ssn
rgEmployeeData.Cells(R, 3).Value = UCase(Trim(ParseInrec(Inrec, 1)))
' last name
If Len(ParseInrec(Inrec, 2)) = 0 Then
MsgBox "Missing Last Name in input file row " & R, vbCritical, "Import Error"
Else
rgEmployeeData.Cells(R, 6).Value = Trim(ParseInrec(Inrec, 2))
End If
' first name
rgEmployeeData.Cells(R, 4).Value = Trim(ParseInrec(Inrec, 3))
' initial
rgEmployeeData.Cells(R, 5).Value = Trim(ParseInrec(Inrec, 4))
' suffix
rgEmployeeData.Cells(R, 7).Value = Trim(ParseInrec(Inrec, 5))
' sEX
If Left(UCase(Trim(ParseInrec(Inrec, 6))), 1) = "M" Then
rgEmployeeData.Cells(R, 8).Value = "M"
End If
If Left(UCase(Trim(ParseInrec(Inrec, 6))), 1) = "F" Then
rgEmployeeData.Cells(R, 8).Value = "F"
End If
' Birthday
If IsDate(ParseInrec(Inrec, 7)) Or Trim(ParseInrec(Inrec, 7)) = "" Then
rgEmployeeData.Cells(R, 9).Value = Trim(ParseInrec(Inrec, 7))
Else
MsgBox "Non-date entry for Birth Date found in input file row " & R, vbCritical, "Import Error"
End If
' Address1
rgEmployeeData.Cells(R, 10).Value = Trim(ParseInrec(Inrec, 8))
' address2
rgEmployeeData.Cells(R, 11).Value = Trim(ParseInrec(Inrec, 9))
' address3
rgEmployeeData.Cells(R, 12).Value = Trim(ParseInrec(Inrec, 10))
' city
rgEmployeeData.Cells(R, 13).Value = Trim(ParseInrec(Inrec, 11))
' state
rgEmployeeData.Cells(R, 14).Value = UCase(Trim(ParseInrec(Inrec, 12)))
' zip
If IsNumeric(Trim(ParseInrec(Inrec, 13))) Or Trim(ParseInrec(Inrec, 13)) = "" Then
rgEmployeeData.Cells(R, 15).Value = Trim(ParseInrec(Inrec, 13))
Else
MsgBox "Non-numeric entry for Zip Code found in input file row " & R, vbCritical, "Import Error"
End If
' Country
rgEmployeeData.Cells(R, 16).Value = Trim(ParseInrec(Inrec, 14))
' phone
If IsNumeric(Trim(ParseInrec(Inrec, 15))) Or Trim(ParseInrec(Inrec, 15)) = "" Then
rgEmployeeData.Cells(R, 17).Value = Trim(ParseInrec(Inrec, 15))
Else
MsgBox "Non-numeric entry for Phone found in input file row " & R, vbCritical, "Import Error"
End If
' e-mail
rgEmployeeData.Cells(R, 18).Value = Trim(ParseInrec(Inrec, 16))
' hire date
If IsDate(ParseInrec(Inrec, 19)) Or Trim(ParseInrec(Inrec, 19)) = "" Then
rgEmployeeData.Cells(R, 19).Value = Trim(ParseInrec(Inrec, 19))
Else
MsgBox "Non-date entry for Hire Date found in input file row " & R, vbCritical, "Import Error"
End If
' term date
If IsDate(ParseInrec(Inrec, 20)) Or Trim(ParseInrec(Inrec, 20)) = "" Then
rgEmployeeData.Cells(R, 20).Value = Trim(ParseInrec(Inrec, 20))
Else
MsgBox "Non-date entry for Termination Date found in input file row " & R, vbCritical, "Import Error"
End If
' future date
If IsDate(ParseInrec(Inrec, 21)) Or Trim(ParseInrec(Inrec, 21)) = "" Then
rgEmployeeData.Cells(R, 21).Value = Trim(ParseInrec(Inrec, 21))
Else
MsgBox "Non-date entry for Future Date found in input file row " & R, vbCritical, "Import Error"
End If
' future status
rgEmployeeData.Cells(R, 22).Value = UCase(Trim(ParseInrec(Inrec, 22)))
' FTE
If IsNumeric(ParseInrec(Inrec, 23)) Then
rgEmployeeData.Cells(R, 23).Value = ParseInrec(Inrec, 23) / 100
Else
MsgBox "Non-numeric entry for FTE found in input file row " & R, vbCritical, "Import Error"
End If
'rgEmployerData.Cells(7, 3).Value = R
Loop
Close #1
MsgBox "Import completed. " & R & " rows imported.", vbInformation, "Success"
Exit Sub
Import_Error:
MsgBox Err.Description & " Record: " & Inrec, vbCritical, "Import"
Exit Sub
File_Error:
'MsgBox Err.Number
If Err.Number = 53 Then ' file not found
MsgBox "Input file not found.", vbCritical, "Bad filename"
Else
MsgBox Err.Number, Err.Description, vbc, "Import"
Resume Next
End If
End Sub
Function ParseInrec(Inrec, FieldNo)
On Error GoTo ParseInrec_Error
Dim Inrec2 As String
Dim I As Integer
Select Case FieldNo
Case Is = 1
Inrec2 = Inrec
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 2
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 3
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 4
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
For I = 1 To FieldNo - 2
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
Next I
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 5
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
For I = 1 To FieldNo - 2
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
Next I
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 6
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
For I = 1 To FieldNo - 2
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
Next I
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 7
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
For I = 1 To FieldNo - 2
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
Next I
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 8
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
For I = 1 To FieldNo - 2
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
Next I
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 9
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
For I = 1 To FieldNo - 2
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
Next I
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 10
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
For I = 1 To FieldNo - 2
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
Next I
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 11
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
For I = 1 To FieldNo - 2
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
Next I
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 12
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
For I = 1 To FieldNo - 2
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
Next I
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 13
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
For I = 1 To FieldNo - 2
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
Next I
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 14
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
For I = 1 To FieldNo - 2
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
Next I
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 15
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
For I = 1 To FieldNo - 2
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
Next I
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 16
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
For I = 1 To FieldNo - 2
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
Next I
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 17
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
For I = 1 To FieldNo - 2
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
Next I
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 18
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
For I = 1 To FieldNo - 2
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
Next I
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 19
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
For I = 1 To FieldNo - 2
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
Next I
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 20
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
For I = 1 To FieldNo - 2
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
Next I
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 21
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
For I = 1 To FieldNo - 2
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
Next I
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 22
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
For I = 1 To FieldNo - 2
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
Next I
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 23
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
For I = 1 To FieldNo - 2
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
Next I
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
End Select
Exit Function
ParseInrec_Error:
MsgBox Err.Description & " R/F: " & R & " " * FieldNo, vbCritical, "ParseInrec"
End Function
I am also attaching excel macro file here.
Our account specialist is using macro for importing and exporting files for years. She is getting an type mismatch error after windows 10 and office 2016 upgrade according to her. I tried to change datatype but still getting a same error message. Do you have any idea to solve this kind of issue? I am also attaching my xlsm file and also xls file.
I attached vba code here.
' v.2 10/29/2002 ' used M for filespec
' Locked cells
' isnumeric validity check for phone number
' v.3 11/1/2002 three period type
' import function added
' v.4 11/19/2002 Output 00's instead of blanks for dates
' Output 000 for undetermined status
' Add one to record count in header record
' v.5 11/21/2002 Output spaces instead of zeros for dates
' v1.0 12/4/2002 Added ad to picklist page, fixed spelling in A12
' v1.1 12/12/2002 Remove address requirement
' v1.2 12/27/2002 Problem with pull-down in A49
' v1.3 1/8/2003 Import fields in wrong order
' v1.4 2/13/03 replace future active '000' with ' '
' 10/15/2012 rch - added code to allow export file location, changed font to white to hide job category and job classification data
Function Validate() As Boolean
On Error GoTo Validate_Error
Dim rgEmployeeData As Range
Dim rgEmployerData As Range
Dim rgJobCategories As Range
Dim rgJobClassification As Range
Set rgEmployeeData = Range("Employeedata")
Set rgEmployerData = Range("employerdata")
Set rgJobCategories = Range("jobcategories")
Set rgJobClassifications = Range("jobclassifications")
Validate = True
' check the employer code is numeric
If Not IsNumeric(rgEmployerData.Cells(1, 3).Value) Then
MsgBox "Invalid Employer code.", vbCritical, "Entry error"
Validate = False
End If
' check the file start code is 3 characters
If Len(Trim(rgEmployerData.Cells(2, 3).Value)) <> 3 Then
MsgBox "Invalid File Start Code.", vbCritical, "Entry Error"
Validate = False
End If
' check monthly/bi-weekly code is a M, B1 or B2
If Not IsNumeric(rgEmployerData.Cells(5, 3).Value) Or rgEmployerData.Cells(5, 3).Value < 1 Or rgEmployerData.Cells(5, 3).Value > 3 Then
MsgBox "Invalid Payroll cycle", vbCritical, "Entry error"
Validate = False
End If
' check File Creation is a date
If Not IsDate(rgEmployerData.Cells(6, 3).Value) Then
MsgBox "Invalid Period Ending Date", vbCritical, "Entry Error"
Validate = False
End If
For I = 1 To 500
' if this record as a SSN or last name check it. Otherwise skip it.
If Trim(rgEmployeeData.Cells(I, 3).Value) <> "" Or Trim(rgEmployeeData.Cells(I, 6).Value) <> "" Then
' check for valid SSN
If Len(rgEmployeeData.Cells(I, 3).Value) <> 9 Then
MsgBox "Invalid Social Security Number for " & Trim(rgEmployeeData.Cells(I, 4).Value) & " " & Trim(rgEmployeeData.Cells(I, 6).Value), vbCritical, "Entry Error"
Validate = False
Exit Function
End If
If Not IsNumeric(rgEmployeeData.Cells(I, 3).Value) Then
MsgBox "Invalid Social Security Number for " & Trim(rgEmployeeData.Cells(I, 4).Value) & " " & Trim(rgEmployeeData.Cells(I, 6).Value), vbCritical, "Entry Error"
Validate = False
Exit Function
End If
' check for valid first
If Len(rgEmployeeData.Cells(I, 4).Value) < 1 Then
MsgBox "Invalid first name for " & rgEmployeeData.Cells(I, 3).Value, vbCritical, "Entry Error"
Validate = False
Exit Function
End If
' check for valid last
If Len(rgEmployeeData.Cells(I, 6).Value) < 1 Then
MsgBox "Invalid last name for " & rgEmployeeData.Cells(I, 3).Value, vbCritical, "Entry Error"
Validate = False
Exit Function
End If
' check for valid sex
If UCase(Left(rgEmployeeData.Cells(I, 8).Value, 1)) = "M" Or UCase(Left(rgEmployeeData.Cells(I, 8).Value, 1)) = "F" Then
Else
MsgBox "Invalid sex for " & rgEmployeeData.Cells(I, 4).Value & " " & rgEmployeeData.Cells(I, 6).Value, vbCritical, "Entry Error"
Validate = False
Exit Function
End If
' check the birth date for validity
If Not IsDate(rgEmployeeData.Cells(I, 9).Value) And Not rgEmployeeData.Cells(I, 9).Value = "" Then
MsgBox "Invalid birth date for " & Trim(rgEmployeeData.Cells(I, 4).Value) & " " & Trim(rgEmployeeData.Cells(I, 6).Value), vbCritical, "Entry Error"
Validate = False
Exit Function
End If
' check for valid address
' If Len(rgEmployeeData.Cells(I, 10).Value) < 1 Then
' MsgBox "Invalid address for " & rgEmployeeData.Cells(I, 4).Value & " " & rgEmployeeData.Cells(I, 6).Value, vbCritical, "Entry Error"
' Validate = False
' Exit Function
' End If
' check for valid city
If Len(rgEmployeeData.Cells(I, 13).Value) < 1 Then
MsgBox "Invalid city for " & rgEmployeeData.Cells(I, 4).Value & " " & rgEmployeeData.Cells(I, 6).Value, vbCritical, "Entry Error"
Validate = False
Exit Function
End If
' check for valid state
If Len(rgEmployeeData.Cells(I, 14).Value) <> 2 Then
MsgBox "Invalid state for " & rgEmployeeData.Cells(I, 4).Value & " " & rgEmployeeData.Cells(I, 6).Value, vbCritical, "Entry Error"
Validate = False
Exit Function
End If
' check for valid zip
If Len(rgEmployeeData.Cells(I, 15).Value) = 5 Or Len(rgEmployeeData.Cells(I, 15).Value) = 9 Then
Else
MsgBox "Invalid zip for " & rgEmployeeData.Cells(I, 4).Value & " " & rgEmployeeData.Cells(I, 6).Value, vbCritical, "Entry Error"
Validate = False
Exit Function
End If
' check for valid phone
If Not IsNumeric(rgEmployeeData(I, 17).Value) Then
MsgBox "Invalid phone for " & rgEmployeeData.Cells(I, 4).Value & " " & rgEmployeeData.Cells(I, 6).Value & " (Numbers only.)", vbCritical, "Entry Error"
Validate = False
Exit Function
End If
If Len(rgEmployeeData.Cells(I, 17).Value) > 10 Then
MsgBox "Invalid phone for " & rgEmployeeData.Cells(I, 4).Value & " " & rgEmployeeData.Cells(I, 6).Value & " (Exceeds 10 chars.)", vbCritical, "Entry Error"
Validate = False
Exit Function
End If
' check the hire date for validity
If Not IsDate(rgEmployeeData.Cells(I, 19).Value) And Not rgEmployeeData.Cells(I, 19).Value = "" Then
MsgBox "Invalid Hire date for " & Trim(rgEmployeeData.Cells(I, 4).Value) & " " & Trim(rgEmployeeData.Cells(I, 6).Value), vbCritical, "Entry Error"
Validate = False
Exit Function
End If
' check termination date
If Not IsDate(rgEmployeeData.Cells(I, 20).Value) And Not rgEmployeeData.Cells(I, 20) = "" Then
MsgBox "Invalid Termination date for " & Trim(rgEmployeeData.Cells(I, 4).Value) & " " & Trim(rgEmployeeData.Cells(I, 6).Value), vbCritical, "Entry Error"
Validate = False
Exit Function
End If
' check Future Status date
If rgEmployeeData.Cells(I, 21).Value <> "" Then
If Not IsDate(rgEmployeeData.Cells(I, 21).Value) Then
MsgBox "Invalid future date for " & Trim(rgEmployeeData.Cells(I, 4).Value) & " " & Trim(rgEmployeeData.Cells(I, 6).Value), vbCritical, "Entry Error"
Validate = False
Exit Function
End If
End If
' check for proper active/term status
If rgEmployeeData.Cells(I, 21).Value <> "" Then
If UCase(Left(rgEmployeeData.Cells(I, 22).Value, 1)) = "A" Or UCase(Left(rgEmployeeData.Cells(I, 8).Value, 1)) = "T" Then
Else
MsgBox "Invalid Active/Term for " & Trim(rgEmployeeData.Cells(I, 4).Value) & " " & Trim(rgEmployeeData.Cells(I, 6).Value), vbCritical, "Entry Error"
Validate = False
Exit Function
End If
End If
' check for proper FTE %
If Not IsNumeric(rgEmployeeData.Cells(I, 23).Value) Then
MsgBox "Invalid FTE % for " & Trim(rgEmployeeData.Cells(I, 4).Value) & " " & Trim(rgEmployeeData.Cells(I, 6).Value), vbCritical, "Entry Error"
Validate = False
Exit Function
End If
If rgEmployeeData.Cells(I, 23).Value > 1 Or rgEmployeeData.Cells(I, 23).Value < 0 Then
MsgBox "Invalid FTE % for " & Trim(rgEmployeeData.Cells(I, 4).Value) & " " & Trim(rgEmployeeData.Cells(I, 6).Value), vbCritical, "Entry Error"
Validate = False
Exit Function
End If
v = RecordCount
End If
Next I
Exit Function
Validate_Error:
MsgBox Err.Description, vbCritical, "Validate"
End Function
Function RecordCount() As Integer
' this function will count the number of records ready to be transmitted
On Error GoTo RecordCount_Error
Dim rgEmployeeData As Range
Dim rgEmployerData As Range
Dim R As Integer
Set rgEmployeeData = Range("Employeedata")
Set rgEmployerData = Range("employerdata")
RecordCount = 0
For R = 1 To 500
If Trim(rgEmployeeData.Cells(R, 3).Value) <> "" Or Trim(rgEmployeeData.Cells(R, 6).Value) <> "" Then
RecordCount = RecordCount + 1
End If
Next R
' compare record count
If RecordCount <> rgEmployerData.Cells(7, 3).Value Then
MsgBox "Updating Record count to: " & RecordCount, vbInformation, "Updating record count"
rgEmployerData.Cells(7, 3) = RecordCount
End If
Exit Function
RecordCount_Error:
MsgBox Err.Description, vbCritical, "RecordCount"
End Function
Sub cmdExport()
On Error GoTo cmdExport_Error
'
'
Dim rgEmployeeData As Range
Dim rgEmployerData As Range
Dim rgJobCategories As Range
Dim rgJobClassification As Range
Dim R As Long, C As Long
Dim FileSpec As String
Dim PLine As String
If Not Validate Then
Exit Sub
End If
Set rgEmployeeData = Range("Employeedata")
Set rgEmployerData = Range("employerdata")
Set rgJobCategories = Range("jobcategories")
Set rgJobClassifications = Range("jobclassifications")
On Error GoTo File_Error
If Right(rgEmployerData.Cells(9, 3).Value, 1) <> "\" Then
rgEmployerData.Cells(9, 3).Value = rgEmployerData.Cells(9, 3).Value & "\"
End If
FileSpec = rgEmployerData.Cells(9, 3).Value & rgEmployerData.Cells(2, 3).Value & Format(rgEmployerData.Cells(6, 3).Value, "MM") & Right(Format(rgEmployerData.Cells(6, 3).Value, "yyyy"), 4) & "M.txt"
Open FileSpec For Input As #1
Close #1
v = MsgBox("The file " & FileSpec & " already exits.", vbOKCancel)
If v = vbCancel Then
Exit Sub
End If
NewFile:
Open FileSpec For Output As #1
On Error GoTo cmdExport_Error
Set rgEmployeeData = Range("Employeedata")
Set rgEmployerData = Range("employerdata")
Set rgJobCategories = Range("jobcategories")
Set rgJobClassifications = Range("jobclassifications")
' first send the header record
' header id
PLine = Format(Date, "mmdd")
' employer code
PLine = PLine & Format(rgEmployerData.Cells(1, 3).Value, "0000000")
' record cound
' add 1 to the record count for the header record
PLine = PLine & Format(rgEmployerData.Cells(7, 3).Value, "00000")
' File creation date period
PLine = PLine & Format(rgEmployerData.Cells(6, 3).Value, "mmddyyyy")
Print #1, PLine
For R = 1 To 500
' if this record has a SSN or last name check it. Otherwise skip it.
If Trim(rgEmployeeData.Cells(R, 3).Value) <> "" Or Trim(rgEmployeeData.Cells(R, 6).Value) <> "" Then
' header id
PLine = Format(Format(Date, "mmdd"), "0000")
' employer code
PLine = PLine & Format(rgEmployerData.Cells(1, 3).Value, "0000000")
' billing entity code
PLine = PLine & Format(rgEmployerData.Cells(4, 3).Value, "0000")
' agreement code
PLine = PLine & Format(rgEmployerData.Cells(5, 3), "000000")
' site code
PLine = PLine & " "
' ssn
PLine = PLine & Format(rgEmployeeData.Cells(R, 3), "000000000")
' last name
PLine = PLine & Left((rgEmployeeData.Cells(R, 6).Value & Space(50)), 50)
' first name
PLine = PLine & Left((rgEmployeeData.Cells(R, 4).Value & Space(50)), 50)
' middle
PLine = PLine & Left((rgEmployeeData.Cells(R, 5).Value & Space(50)), 50)
' suffix
PLine = PLine & Left((rgEmployeeData.Cells(R, 7).Value & Space(3)), 3)
' sex
PLine = PLine & UCase(Left((rgEmployeeData.Cells(R, 8).Value & Space(3)), 1))
' birthdate
PLine = PLine & Format(rgEmployeeData.Cells(R, 9).Value, "mmddyyyy")
' address 1
PLine = PLine & Left((rgEmployeeData.Cells(R, 10).Value & Space(50)), 50)
' address 2
PLine = PLine & Left((rgEmployeeData.Cells(R, 11).Value & Space(50)), 50)
' address 3
PLine = PLine & Left((rgEmployeeData.Cells(R, 12).Value & Space(50)), 50)
' city
PLine = PLine & Left((rgEmployeeData.Cells(R, 13).Value & Space(50)), 50)
' state
PLine = PLine & Left((rgEmployeeData.Cells(R, 14).Value & Space(2)), 2)
' zip
PLine = PLine & Left((rgEmployeeData.Cells(R, 15).Value & Space(9)), 9)
' country
PLine = PLine & Left((rgEmployeeData.Cells(R, 16).Value & Space(3)), 3)
' phone
PLine = PLine & Left((rgEmployeeData.Cells(R, 17).Value & Space(10)), 10)
PLine = PLine & Left((rgEmployeeData.Cells(R, 18).Value & Space(30)), 30)
' job category
Select Case rgEmployeeData.Cells(R, 1)
Case 1
PLine = PLine & Left(rgJobCategories.Cells(1, 1) + Space(2), 2)
Case 2
PLine = PLine & Left(rgJobCategories.Cells(2, 1) + Space(2), 2)
Case 3
PLine = PLine & Left(rgJobCategories.Cells(3, 1) + Space(2), 2)
Case 4
PLine = PLine & Left(rgJobCategories.Cells(4, 1) + Space(2), 2)
Case 5
PLine = PLine & Left(rgJobCategories.Cells(5, 1) + Space(2), 2)
Case 6
PLine = PLine & Left(rgJobCategories.Cells(6, 1) + Space(2), 2)
Case 7
PLine = PLine & Left(rgJobCategories.Cells(7, 1) + Space(2), 2)
Case 8
PLine = PLine & Left(rgJobCategories.Cells(8, 1) + Space(2), 2)
Case Else
MsgBox "You have entered an invalid Job Category on row " & R & ".", vbCritical, "Invalid data"
Exit Sub
End Select
' job classification
Select Case rgEmployeeData.Cells(R, 2)
Case 1
PLine = PLine & Left(rgJobClassifications.Cells(1, 1) + Space(2), 2)
Case 2
PLine = PLine & Left(rgJobClassifications.Cells(2, 1) + Space(2), 2)
Case 3
PLine = PLine & Left(rgJobClassifications.Cells(3, 1) + Space(2), 2)
Case 4
PLine = PLine & Left(rgJobClassifications.Cells(4, 1) + Space(2), 2)
Case Else
MsgBox "You have entered an invalid Job Category on row " & R & ".", vbCritical, "Invalid data"
Exit Sub
End Select
' hire date
If rgEmployeeData.Cells(R, 19).Value = "" Then
PLine = PLine & Space(8)
Else
PLine = PLine & Format(rgEmployeeData.Cells(R, 19).Value, "mmddyyyy")
End If
' termination date
If rgEmployeeData.Cells(R, 20).Value = "" Then
PLine = PLine & Space(8)
Else
PLine = PLine & Format(rgEmployeeData.Cells(R, 20).Value, "mmddyyyy")
End If
' future status date
If rgEmployeeData.Cells(R, 21).Value = "" Then
PLine = PLine & Space(8)
Else
PLine = PLine & Format(rgEmployeeData.Cells(R, 21).Value, "mmddyyyy")
End If
' future status
Select Case UCase(Left(rgEmployeeData.Cells(R, 22), 1))
Case "A"
PLine = PLine & "ACT"
Case "T"
PLine = PLine & "TRM"
Case Else
PLine = PLine & " "
End Select
' fte percentage
PLine = PLine & Format(rgEmployeeData.Cells(R, 23).Value * 100, "000")
Print #1, PLine
End If
Next R
Close #1
MsgBox "Export file: " & FileSpec & " created.", vbInformation, "Success"
Exit Sub
cmdExport_Error:
MsgBox Err.Description, vbCritical, "cmdExport"
Exit Sub
File_Error:
'MsgBox Err.Number
If Err.Number = 53 Then ' file not found
Resume NewFile:
Else
MsgBox Err.Number, Err.Description, vbc, "cmdExport"
Resume Next
End If
End Sub
Sub Showform()
Load MemberForm
MemberForm.Show
End Sub
Sub Import()
On Error GoTo Import_Error
'
'
Dim rgEmployeeData As Range
Dim rgEmployerData As Range
Dim rgJobCategories As Range
Dim rgJobClassification As Range
Dim R As Long, C As Long
Dim FileSpec As String
Dim PLine As String
Dim JobCategory, JobClassifiction, SSN, FName, MName, Lname, Suffix, Active, Gross, Member, Total, FTE, HireDate, TerminationDate As String
Dim Inrec As String
Set rgEmployeeData = Range("Employeedata")
Set rgEmployerData = Range("employerdata")
Set rgJobCategories = Range("jobcategories")
Set rgJobClassifications = Range("jobclassifications")
' clear the rows
For R = 1 To 2
For C = 1 To 2
rgEmployeeData.Cells(R, C).Value = ""
Next C
Next R
R = 0
On Error GoTo File_Error
FileSpec = rgEmployerData.Cells(8, 3).Value
Open FileSpec For Input As #1
On Error GoTo Import_Error
Do While Not EOF(1)
Line Input #1, Inrec
R = R + 1
' job category
x = UCase(Trim(ParseInrec(Inrec, 1)))
Select Case UCase(Trim(ParseInrec(Inrec, 17)))
Case "R"
rgEmployeeData.Cells(R, 1) = 1
Case "RT"
rgEmployeeData.Cells(R, 1) = 2
Case "RP"
rgEmployeeData.Cells(R, 1) = 3
Case "AP"
rgEmployeeData.Cells(R, 1) = 4
Case "RE"
rgEmployeeData.Cells(R, 1) = 5
Case "RW"
rgEmployeeData.Cells(R, 1) = 6
Case "LW"
rgEmployeeData.Cells(R, 1) = 7
Case "PT"
rgEmployeeData.Cells(R, 1) = 8
Case Else
MsgBox "Invalid Job Category in input file row " & R, vbCritical, "Import Error"
Exit Sub
End Select
' job classification
Select Case UCase(Trim(ParseInrec(Inrec, 18)))
Case "AD"
rgEmployeeData.Cells(R, 2) = 1
Case "TE"
rgEmployeeData.Cells(R, 2) = 2
Case "OC"
rgEmployeeData.Cells(R, 2) = 3
Case "NC"
rgEmployeeData.Cells(R, 2) = 4
Case Else
MsgBox "Invalid Job Classification in input file row " & R, vbCritical, "Import Error"
Exit Sub
End Select
' ssn
rgEmployeeData.Cells(R, 3).Value = UCase(Trim(ParseInrec(Inrec, 1)))
' last name
If Len(ParseInrec(Inrec, 2)) = 0 Then
MsgBox "Missing Last Name in input file row " & R, vbCritical, "Import Error"
Else
rgEmployeeData.Cells(R, 6).Value = Trim(ParseInrec(Inrec, 2))
End If
' first name
rgEmployeeData.Cells(R, 4).Value = Trim(ParseInrec(Inrec, 3))
' initial
rgEmployeeData.Cells(R, 5).Value = Trim(ParseInrec(Inrec, 4))
' suffix
rgEmployeeData.Cells(R, 7).Value = Trim(ParseInrec(Inrec, 5))
' sEX
If Left(UCase(Trim(ParseInrec(Inrec, 6))), 1) = "M" Then
rgEmployeeData.Cells(R, 8).Value = "M"
End If
If Left(UCase(Trim(ParseInrec(Inrec, 6))), 1) = "F" Then
rgEmployeeData.Cells(R, 8).Value = "F"
End If
' Birthday
If IsDate(ParseInrec(Inrec, 7)) Or Trim(ParseInrec(Inrec, 7)) = "" Then
rgEmployeeData.Cells(R, 9).Value = Trim(ParseInrec(Inrec, 7))
Else
MsgBox "Non-date entry for Birth Date found in input file row " & R, vbCritical, "Import Error"
End If
' Address1
rgEmployeeData.Cells(R, 10).Value = Trim(ParseInrec(Inrec, 8))
' address2
rgEmployeeData.Cells(R, 11).Value = Trim(ParseInrec(Inrec, 9))
' address3
rgEmployeeData.Cells(R, 12).Value = Trim(ParseInrec(Inrec, 10))
' city
rgEmployeeData.Cells(R, 13).Value = Trim(ParseInrec(Inrec, 11))
' state
rgEmployeeData.Cells(R, 14).Value = UCase(Trim(ParseInrec(Inrec, 12)))
' zip
If IsNumeric(Trim(ParseInrec(Inrec, 13))) Or Trim(ParseInrec(Inrec, 13)) = "" Then
rgEmployeeData.Cells(R, 15).Value = Trim(ParseInrec(Inrec, 13))
Else
MsgBox "Non-numeric entry for Zip Code found in input file row " & R, vbCritical, "Import Error"
End If
' Country
rgEmployeeData.Cells(R, 16).Value = Trim(ParseInrec(Inrec, 14))
' phone
If IsNumeric(Trim(ParseInrec(Inrec, 15))) Or Trim(ParseInrec(Inrec, 15)) = "" Then
rgEmployeeData.Cells(R, 17).Value = Trim(ParseInrec(Inrec, 15))
Else
MsgBox "Non-numeric entry for Phone found in input file row " & R, vbCritical, "Import Error"
End If
rgEmployeeData.Cells(R, 18).Value = Trim(ParseInrec(Inrec, 16))
' hire date
If IsDate(ParseInrec(Inrec, 19)) Or Trim(ParseInrec(Inrec, 19)) = "" Then
rgEmployeeData.Cells(R, 19).Value = Trim(ParseInrec(Inrec, 19))
Else
MsgBox "Non-date entry for Hire Date found in input file row " & R, vbCritical, "Import Error"
End If
' term date
If IsDate(ParseInrec(Inrec, 20)) Or Trim(ParseInrec(Inrec, 20)) = "" Then
rgEmployeeData.Cells(R, 20).Value = Trim(ParseInrec(Inrec, 20))
Else
MsgBox "Non-date entry for Termination Date found in input file row " & R, vbCritical, "Import Error"
End If
' future date
If IsDate(ParseInrec(Inrec, 21)) Or Trim(ParseInrec(Inrec, 21)) = "" Then
rgEmployeeData.Cells(R, 21).Value = Trim(ParseInrec(Inrec, 21))
Else
MsgBox "Non-date entry for Future Date found in input file row " & R, vbCritical, "Import Error"
End If
' future status
rgEmployeeData.Cells(R, 22).Value = UCase(Trim(ParseInrec(Inrec, 22)))
' FTE
If IsNumeric(ParseInrec(Inrec, 23)) Then
rgEmployeeData.Cells(R, 23).Value = ParseInrec(Inrec, 23) / 100
Else
MsgBox "Non-numeric entry for FTE found in input file row " & R, vbCritical, "Import Error"
End If
'rgEmployerData.Cells(7, 3).Value = R
Loop
Close #1
MsgBox "Import completed. " & R & " rows imported.", vbInformation, "Success"
Exit Sub
Import_Error:
MsgBox Err.Description & " Record: " & Inrec, vbCritical, "Import"
Exit Sub
File_Error:
'MsgBox Err.Number
If Err.Number = 53 Then ' file not found
MsgBox "Input file not found.", vbCritical, "Bad filename"
Else
MsgBox Err.Number, Err.Description, vbc, "Import"
Resume Next
End If
End Sub
Function ParseInrec(Inrec, FieldNo)
On Error GoTo ParseInrec_Error
Dim Inrec2 As String
Dim I As Integer
Select Case FieldNo
Case Is = 1
Inrec2 = Inrec
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 2
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 3
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 4
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
For I = 1 To FieldNo - 2
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
Next I
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 5
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
For I = 1 To FieldNo - 2
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
Next I
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 6
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
For I = 1 To FieldNo - 2
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
Next I
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 7
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
For I = 1 To FieldNo - 2
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
Next I
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 8
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
For I = 1 To FieldNo - 2
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
Next I
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 9
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
For I = 1 To FieldNo - 2
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
Next I
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 10
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
For I = 1 To FieldNo - 2
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
Next I
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 11
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
For I = 1 To FieldNo - 2
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
Next I
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 12
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
For I = 1 To FieldNo - 2
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
Next I
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 13
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
For I = 1 To FieldNo - 2
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
Next I
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 14
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
For I = 1 To FieldNo - 2
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
Next I
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 15
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
For I = 1 To FieldNo - 2
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
Next I
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 16
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
For I = 1 To FieldNo - 2
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
Next I
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 17
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
For I = 1 To FieldNo - 2
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
Next I
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 18
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
For I = 1 To FieldNo - 2
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
Next I
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 19
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
For I = 1 To FieldNo - 2
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
Next I
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 20
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
For I = 1 To FieldNo - 2
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
Next I
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 21
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
For I = 1 To FieldNo - 2
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
Next I
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 22
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
For I = 1 To FieldNo - 2
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
Next I
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
Case Is = 23
Inrec2 = Right(Inrec, Len(Inrec) - (InStr(1, Inrec, ",")))
For I = 1 To FieldNo - 2
Inrec2 = Right(Inrec2, Len(Inrec2) - (InStr(1, Inrec2, ",")))
Next I
ParseInrec = Left(Inrec2, (InStr(1, Inrec2, ",") - 1))
End Select
Exit Function
ParseInrec_Error:
MsgBox Err.Description & " R/F: " & R & " " * FieldNo, vbCritical, "ParseInrec"
End Function
I am also attaching excel macro file here.