code to compare two worksheets and find the difference in fo

trimmer69

Active Member
Joined
May 22, 2004
Messages
414
i have 2 worksheets that appear to be the same,but the code i am using will only work on one workbook. I have tried formatting as general then as fractions, i have tried removing all formats but the code will work on one ws and not the other. Is there some code that will look at each sheet and be able to compare formatting
 

Some videos you may like

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.

XLGibbs

Well-known Member
Joined
Feb 25, 2005
Messages
2,446
The problem is not the formatting.

Are you using code or formulas?

In the code, it is probably specifically referencing the first worksheet. You would have to change the code to look at the second...

If you have code, post it for more help.
 

trimmer69

Active Member
Joined
May 22, 2004
Messages
414
This code was generated in xls97 but since my company has upgraded to 2003. it works great for pma strappings and half the time for ews strappings. i get run-time error 13
Rich (BB code):
Attribute VB_Name = "Module1"

Function F_t(x As String)
On Error GoTo per1
    berta = Trim(x)
    ftti = Len(berta)
    ftt = InStr(1, CStr(berta), "'", vbTextCompare)
    ftt1 = InStr(1, CStr(berta), "-", vbTextCompare)
    ftt2 = InStr(1, CStr(berta), " ", vbTextCompare)
    If ftt <> 0 And ftt < ftti Then
        fttf = ftt: intr = "'"
    ElseIf ftt1 <> 0 And ftt1 < ftt2 Or ftt2 = 0 Then
        fttf = ftt1: intr = "-"
    Else
        fttf = ftt2: intr = " "
    End If
    ftt3 = Trim(Left(berta, fttf - 1))
    F_t = ftt3
per1:
End Function
Function I_n(x As String)
On Error GoTo per1
    ftt2 = F_t(x)
    lrg = Len(ftt2)
    berta = Trim(Mid(x, lrg + 2, Len(x)))
    If Left(berta, 1) = "-" Then berta = Trim(Mid(x, lrg + 3, Len(x)))
    fttf = 2
    ftt = InStr(1, CStr(berta), Chr(34), vbTextCompare): ftt1 = InStr(1, CStr(berta), "-", vbTextCompare)
    ftt2 = InStr(1, CStr(berta), " ", vbTextCompare)
    If ftt = fttf Or ftt1 = fttf Then fttf = 1
    If ftt <> 0 Then
        intr1 = Chr(34)
    ElseIf ftt1 <> 0 Then
        intr1 = "-"
    Else
        intr1 = " "
    End If
    fttd = InStr(1, berta, "/", vbTextCompare)
    If fttd <> 0 And ftt1 = 0 And ftt2 = 0 And ftt = Len(berta) Or fttd <> 0 And ftt = Len(berta) And ftt1 = 0 And ftt2 = 0 Then
        MsgBox "Give a Space between Inches and Fraction in Present measurement", vbExclamation, "Inches Fraction"
        End
    End If
    ftt4 = Trim(Left(berta, fttf))
    I_n = CDbl(ftt4)
per1:
End Function
Function F_r(x As String)
On Error GoTo per1
    berta = Trim(x)
    ftt2 = F_t(x)
    lrg = Len(ftt2) + 1
    ftt21 = I_n(x)
    lrg1 = Len(ftt21)
    To_tal = lrg + lrg1
    ftt = InStr(1, berta, "/", vbTextCompare)
    If ftt = 0 Then
        If To_tal <> Len(berta) Then
            F_r = Right(berta, 1)
        Else
            F_r = 0
        End If
        Exit Function
    End If
    ftt345 = Trim(Right(berta, Len(berta) - ftt + 3))
    If Left(ftt345, 1) = Chr(34) Or Left(ftt345, 1) = "-" Then ftt345 = Trim(Right(berta, Len(berta) - ftt + 2))
    If Right(ftt345, 1) = Chr(34) Then ftt345 = Trim(Left(ftt345, Len(ftt345) - 1))
    F_r = ftt345
per1:
End Function
Function Fr_Un(x)
    If x = "0" Or x = "0/0" Or x = "" Then
        Fr_Un = 0
        Exit Function
    End If
    ftt5 = x
    nu1 = InStr(1, ftt5, "/", vbTextCompare)
    If nu1 = 0 Then
        Fr_Un = x * 0.125
        Exit Function
    End If
    ftt5a = Left(ftt5, nu1 - 1)
    ftt5b = Right(ftt5, Len(ftt5) - nu1)
    Fr_Un = ftt5a / ftt5b
End Function
Function Ft_Uni(x As String)
    Ft_Uni = (F_t(x) * 12) + I_n(x) + Fr_Un(F_r(x))
End Function

Sub PmaRunsheets()
   With ActiveWorkbook
        .Protect "", True, True
        .Unprotect
    End With
'    PM_A = STARTING IN COLUMN A,TOTAL COLUMNS USED FOR STRAPPING
'    PM_A1 = ROW IN WHICH THE STRAPPINGS START.  IE: O FT. , 1 FT.,
'    PM_A2 = ZERO GAUGE OF STRAPPINGS. IS THE FIRST INCREMENT OF STRAPPING CHART
'    PM_A3 = ZERO GAUGE OF STRAPPINGS TO THE START OF THE SECOND PAGE OF STRAPPING START IE: 10 FT. 11 FT.
'    PM_A4 = 14 TEXT REF.HEIGHT
'    PM_A5 = CELL WITH REFERENCE HEIGHT IN IT
'    PMA_6 = COVERS 1 FOOT RANGE IN 1/4 INCREMENT'S 0.0 TO 11.75 INCHES
        PM_A = 21: PM_A1 = 6: PM_A2 = 7: PM_A3 = 66: PM_A4 = 14: PM_A5 = "T5": PMA_6 = 48: PMA_7 = 7
    msj = InputBox("Select Company:" & Chr(13) & "PMA = 1" & Chr(13) & "Inspectorate = 2" & Chr(13) & "Saybolt = 3" _
        & Chr(13) & "ITS = 4", "Select Calibration Company", 1)
    
    
    Select Case msj
        Case Is = 2
           PM_A = 31: PM_A1 = 8: PM_A2 = 9: PM_A3 = 79: PM_A4 = 14: PM_A5 = "L60": PMA_6 = 49 'INSPECTORATE
        Case Is = 3
         ' PM_4 GAUGE HEIGHT = 13
         ' PM_4 MMC GAUGE HEIGHT =17
         ' PM_4 HERMETIC GAUGE HEIGHT = 22
             Rows("1:3").Delete: Rows("57:58").Delete
                     
             PM_A = 21: PM_A4 = 13: PM_A5 = "B5": PMA_7 = 7: PMA_6 = 48 'SAYBOLT
          
        Case Is = 4
           PM_A3 = 62: PM_A5 = "U5" 'ITS
    End Select
    F_F = InputBox("How many pages do you Have to transform?" & Chr(13) & "By default is 2", "pages...", 2)
    On Error Resume Next 'GoTo 95
    Application.DisplayAlerts = False
    Worksheets.Add.Move After:=Worksheets(Worksheets.Count): huy = Sheets.Count: huy = Sheets(huy).Name
95  If Err.Number = 1004 Then
        GoTo 96
'    Else
'        GoTo 49
    End If
96  Application.DisplayAlerts = False
    MO = PM_A2: MO1 = PM_A1 'CHANGE
    lo = 3
    M_e = 0
    MI = 2
    TEL = Sheets("Sheet1").Range(PM_A5): If PM_A5 = "L58" Then TEL = Application.WorksheetFunction.Replace(TEL, Application.WorksheetFunction.Search("REFERENCE ", TEL), 1, "")
    Hei_RefI = Mid(Application.WorksheetFunction.Replace(TEL, Application.WorksheetFunction.Search("'", TEL), 1, ""), PM_A4, 10)
    Hei_RefI = Application.WorksheetFunction.Replace(Hei_RefI, Application.WorksheetFunction.Search(Chr(34), Hei_RefI), 1, "")
    Hei_Ref = Ft_Uni(CStr(Hei_RefI))
    Sheets(huy).Range("a1") = " ": Sheets(huy).Range("b1") = Hei_Ref
    Do Until q > F_F
        N = PM_A3 * q 'CHANGE
        Do Until lo > PM_A 'CHANGE
        On Error GoTo 49
            c_u = CDbl(Trim(Left(Sheets("Sheet1").Cells(MO1 + N, lo), 3))) * 12
            Do Until MO - PMA_7 = PMA_6 'CHANGE
                If lo > PM_A Then Exit Do
                If InStr(1, Sheets("Sheet1").Cells(MO + N, lo - 1), "/", vbTextCompare) = 0 Then
                    M_e1 = Sheets("Sheet1").Cells(MO + N, lo - 1)
                    M_e = c_u + M_e1
                Else
                    M_e = c_u + M_e1 + Fr_Un(Sheets("Sheet1").Cells(MO + N, lo - 1))
                End If
                If Sheets(huy).Cells(MI - 1, 1) = M_e Or _
                    InStr(1, Sheets("Sheet1").Cells(MO + N, lo), "F", 3) <> 0 Then GoTo 140
                If Trim(Sheets("Sheet1").Cells(MO + N, lo)) <> "" Then
                    Sheets(huy).Cells(MI, 1) = M_e
                    Sheets(huy).Cells(MI, 2) = Sheets("Sheet1").Cells(MO + N, lo)
                    'Sheets(HUY).Cells(mi, 5) = Hei_ref - M_e
                    'Sheets(HUY).Cells(mi, 6) = Cells(mo + n, lo)
                    MI = MI + 1
                End If
140                MO = MO + 1
            Loop
            MO = PMA_7: lo = lo + 2
        Loop
        lo = 3
        q = q + 1
    Loop
    
    'run-time error 13 type mismatch on line of code below

49  DES1 = Application.WorksheetFunction.RoundDown(Sheets(huy).Cells(MI - 1, 1) - 3, 0)
    MO1 = 2: mo1a = 2: mo1b = 3
    Sheets(huy).Cells(2, 5) = Sheets(huy).Cells(2, 1): CA_TE = Application.Ceiling(Sheets(huy).Cells(2, 1), 3)
    If CA_TE = 0 Or CA_TE = Sheets(huy).Cells(2, 1) Then CA_TE = CA_TE + 3
    If Sheets(huy).Cells(2, 1) = 0 Then GoTo 165
    Sheets(huy).Cells(3, 5) = CA_TE
    Sheets(huy).Cells(2, 6) = Sheets(huy).Cells(2, 2)
    des = Sheets(huy).Cells(3, 5)
    Do Until Sheets(huy).Cells(MO1, 1) = DES1
        If Sheets(huy).Cells(MO1, 1) = des Then
            Sheets(huy).Cells(mo1b, 6) = Sheets(huy).Cells(MO1, 2)
            mo1b = mo1b + 1
            des = des + 3
            Sheets(huy).Cells(mo1b, 5) = des
        End If
        MO1 = MO1 + 1
    Loop
    Sheets(huy).Cells(mo1b, 6) = Sheets(huy).Cells(MO1, 2)
    Do Until Sheets(huy).Cells(MO1, 1) = ""
        Sheets(huy).Cells(mo1b, 5) = Sheets(huy).Cells(MO1, 1)
        Sheets(huy).Cells(mo1b, 6) = Sheets(huy).Cells(MO1, 2)
        mo1b = mo1b + 1
        MO1 = MO1 + 1
    Loop
    GoTo 173
165 mo1b = 2
    Do Until Sheets(huy).Cells(MO1, 1) > 3
        Sheets(huy).Cells(mo1b, 5) = Sheets(huy).Cells(MO1, 1)
        Sheets(huy).Cells(mo1b, 6) = Sheets(huy).Cells(MO1, 2)
        mo1b = mo1b + 1
        MO1 = MO1 + 1
    Loop
    MO1 = MO1 + 11
    Do Until Sheets(huy).Cells(MO1, 1) = ""
        Sheets(huy).Cells(mo1b, 5) = Sheets(huy).Cells(MO1, 1)
        Sheets(huy).Cells(mo1b, 6) = Sheets(huy).Cells(MO1, 2)
        mo1b = mo1b + 1
        MO1 = MO1 + 12
    Loop
    Sheets(huy).Cells(mo1b, 5) = Sheets(huy).Cells(MI - 1, 1)
    Sheets(huy).Cells(mo1b, 6) = Sheets(huy).Cells(MI - 1, 2)
173 cas = Sheets(huy).Range("e2:f" & MI)
    Sheets(huy).Range("a2:b" & MI) = cas
    Sheets(huy).Range("e2:f" & MI) = ""
    Application.DisplayAlerts = False
    Sheets(huy).Activate
    Dim x As Long
    Dim LastRow As Long
    LastRow = Range("B100").End(xlUp).Row
    For x = LastRow To 1 Step -1
        If Application.WorksheetFunction.CountIf(Range("B:B"), Range("B" & x).Value) > 1 Then
            Range("B" & x).EntireRow.Delete
        End If
    Next
    F_F = ActiveWorkbook.Name: F_F1 = Format(Trim(Left(F_F, 5)), ">")
    F_F23 = Mid(F_F, 7, Len(F_F)): FILENAME1 = Application.WorksheetFunction.Replace(F_F23, Application.WorksheetFunction.Search(".Xls", F_F23), 4, "")
    If InStr(1, FILENAME1, " ") > 0 Then _
        FILENAME1 = Application.WorksheetFunction.Replace(FILENAME1, Application.WorksheetFunction.Search(" ", FILENAME1), 1, "")
    If InStr(1, FILENAME1, " ") > 0 Then _
        FILENAME1 = Application.WorksheetFunction.Replace(FILENAME1, Application.WorksheetFunction.Search(" ", FILENAME1), 1, "")
    If InStr(1, FILENAME1, "B") > 0 Then
        FILENAME1 = Application.WorksheetFunction.Replace(FILENAME1, Application.WorksheetFunction.Search("B", FILENAME1), 1, "")
        If InStr(1, FILENAME1, " ") > 0 Then _
        FILENAME1 = Application.WorksheetFunction.Replace(FILENAME1, Application.WorksheetFunction.Search(" ", FILENAME1), 1, "")
        If InStr(1, FILENAME1, " ") > 0 Then _
        FILENAME1 = Application.WorksheetFunction.Replace(FILENAME1, Application.WorksheetFunction.Search(" ", FILENAME1), 1, "")
    End If
    If InStr(1, FILENAME1, "T") > 0 Then
        FILENAME1 = Application.WorksheetFunction.Replace(FILENAME1, Application.WorksheetFunction.Search("T", FILENAME1), 1, "")
        If InStr(1, FILENAME1, " ") > 0 Then _
        FILENAME1 = Application.WorksheetFunction.Replace(FILENAME1, Application.WorksheetFunction.Search(" ", FILENAME1), 1, "")
        If InStr(1, FILENAME1, " ") > 0 Then _
        FILENAME1 = Application.WorksheetFunction.Replace(FILENAME1, Application.WorksheetFunction.Search(" ", FILENAME1), 1, "")
    End If
    F_F22 = Application.WorksheetFunction.Replace(F_F, Application.WorksheetFunction.Search(".Xls", F_F), 4, "")
    If F_F1 <> "KIRBY" Then FILENAME1 = InputBox("This is File Name", "No Kirby", F_F22)
    ActiveWorkbook.SaveAs Filename:="H:\CSV FILES\new csv\" & FILENAME1 & ".csv", _
    FileFormat:=xlCSV, CreateBackup:=False
    Application.DisplayAlerts = False
    ActiveWorkbook.Close
    Application.DisplayAlerts = True
End Sub
thanks for reviewing
 

trimmer69

Active Member
Joined
May 22, 2004
Messages
414
49 DES1 = Application.WorksheetFunction.RoundDown(Sheets(huy).Cells(MI - 1, 1) - 3, 0)
 

XLGibbs

Well-known Member
Joined
Feb 25, 2005
Messages
2,446
Okay, I was going through this, without being able to run it of course, but the nearest I can come to an answer is the value in that line

DES1 = Application.WorksheetFunction.RoundDown(Sheets(huy).Cells(MI - 1, 1) - 3, 0)

is not a value, specifically, whatever is in cells(MI-1,1)

if it is a number, but in text format you can circumvent by
Code:
DES1 = Application.WorksheetFunction.RoundDown (Val(Sheets(huy).Cells(MI - 1, 1) - 3, 0))

Which will convert it to a value outside the remainder of the function, thus allowing it to ROUNDDOWN.

I didn;t notice your highlight in the code above until after you pointed out which line it was on...sorry took awhile to get back.
 

Watch MrExcel Video

Forum statistics

Threads
1,118,680
Messages
5,573,624
Members
412,539
Latest member
itchy00
Top