code to compare two worksheets and find the difference in fo

F

FROGGER24

Well-known Member
Joined
May 22, 2004
Messages
704
Office Version
  1. 2013
  2. 2010
Platform
  1. Windows
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
 

Excel Facts

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.
Sort by date Sort by votes
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.
 
Upvote 0
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
 
Upvote 0
49 DES1 = Application.WorksheetFunction.RoundDown(Sheets(huy).Cells(MI - 1, 1) - 3, 0)
 
Upvote 0
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.
 
Upvote 0
You must log in or register to reply here.

Similar threads

T
  • Question
Compare spreadsheet/worksheet with changing rows
Replies
2
Views
83
BenW71
B
L
  • Question
Comparing two different worksheets/datasets
Replies
1
Views
262
HighAndWilder
H
B
  • Question
Excel VBA When new rows are added to table 1 copy the information to table 2
Replies
0
Views
415
BlueHawker42
B
gheyman
  • Solved
Comparing two workbooks
Replies
3
Views
407
MountainFog
M
X
  • Question
Compare two Excel highlighting differences within the cells.
Replies
4
Views
283
rlv01
R

Forum statistics

Threads
1,214,925
Messages
6,122,298
Members
449,077
Latest member
Rkmenon

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top