type mismatch error in macro in excel

Discussion in 'Excel' started by RV16, Aug 29, 2016.

  1. RV16

    RV16

    Joined:
    Aug 29, 2016
    Messages:
    1
    Likes Received:
    0
    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.
     
    RV16, Aug 29, 2016
    #1
    1. Advertisements

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments (here). After that, you can post your question and our members will help you out.
Similar Threads
  1. chel
    Replies:
    0
    Views:
    524
  2. jushin100
    Replies:
    1
    Views:
    984
    madonaalbert
    Jun 21, 2012
  3. vahid
    Replies:
    0
    Views:
    292
    vahid
    Apr 21, 2015
  4. HoodGordon
    Replies:
    0
    Views:
    720
    HoodGordon
    Apr 25, 2015
  5. RandellLeon
    Replies:
    0
    Views:
    407
    RandellLeon
    May 13, 2015
  6. CharleGilb
    Replies:
    0
    Views:
    529
    CharleGilb
    May 23, 2015
  7. Pete Marsh
    Replies:
    0
    Views:
    363
    Pete Marsh
    Nov 26, 2015
  8. Pete Marsh
    Replies:
    0
    Views:
    279
    Pete Marsh
    Nov 26, 2015
Loading...