Consulting

Results 1 to 6 of 6

Thread: VBA Help

  1. #1

    VBA Help

    Hey everyone,


    The VBA code, attached with workbook, is used to compare two spreadsheets. The output of this code creates a new sheet that shows the differences have occurred, and if no difference, it leaves the cell blank. And I would like to do the following:

    1) Keep and copy the first row (variable name) into the new produced sheet.

    2) Keep columns A (id), B (name), and E (comp) without comparison, and copy them into the new sheet as identifying variables (they are similar in both sheets).

    3) Delete any row that has no changes.

    The workbook is attached.
    Thanks!!
    Attached Files Attached Files

  2. #2
    Distinguished Lord of VBAX VBAX Grand Master Bob Phillips's Avatar
    Joined
    Apr 2005
    Posts
    25,443
    Location
    Isn't every row different in one of the columns?
    ____________________________________________
    Nihil simul inventum est et perfectum

    Abusus non tollit usum

    Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
    James Thurber

  3. #3
    No, actually, they are not. Try to run the macro and you will see that similar cells will be blank in the new worksheet.

    Quote Originally Posted by xld
    Isn't every row different in one of the columns?

  4. #4
    Distinguished Lord of VBAX VBAX Grand Master Bob Phillips's Avatar
    Joined
    Apr 2005
    Posts
    25,443
    Location
    Oops., I thought you were looking for full code, didn't realise you had some, I just eyeballed the data

    [vba]

    Sub CompareWorksheets(ws1 As Worksheet, ws2 As Worksheet)
    Dim r As Long, c As Integer
    Dim lr1 As Long, lr2 As Long, lc1 As Integer, lc2 As Integer
    Dim maxR As Long, maxC As Integer, cf1 As String, cf2 As String
    Dim rptWB As Workbook, rptWS As Worksheet
    Dim DiffCount As Long
    Dim shCount As Long

    Application.ScreenUpdating = False
    Application.StatusBar = "Creating the report..."

    Application.DisplayAlerts = False
    shCount = Application.SheetsInNewWorkbook
    Application.SheetsInNewWorkbook = 1
    Set rptWB = Workbooks.Add
    Set rptWS = rptWB.Worksheets(1)
    Application.SheetsInNewWorkbook = shCount
    Application.DisplayAlerts = True

    With ws1.UsedRange

    lr1 = .Rows.Count
    lc1 = .Columns.Count
    End With

    With ws2.UsedRange

    lr2 = .Rows.Count
    lc2 = .Columns.Count
    End With

    maxR = lr1
    maxC = lc1
    If maxR < lr2 Then maxR = lr2
    If maxC < lc2 Then maxC = lc2
    DiffCount = 0
    For c = 1 To maxC

    Application.StatusBar = "Comparing cells " & Format(c / maxC, "0 %") & "..."
    For r = 1 To maxR

    cf1 = ""
    cf2 = ""
    On Error Resume Next
    cf1 = ws1.Cells(r, c).FormulaLocal
    cf2 = ws2.Cells(r, c).FormulaLocal
    On Error GoTo 0
    If cf1 <> cf2 Then

    DiffCount = DiffCount + 1
    rptWS.Cells(r, c).Formula = "'" & cf1 & " <> " & cf2
    End If

    ws1.Cells(r, "A").Resize(1, 3).Copy rptWS.Cells(r, "A")
    Next r
    Next c

    rptWS.Columns(1).Value = rptWS.Columns(1).Value
    For r = maxR To 2 Step -1

    If Application.CountIf(rptWS.Cells(r, "D").Resize(1, 100), "<>") = 0 Then

    rptWS.Rows(r).Delete
    End If
    Next r

    Application.StatusBar = "Formatting the report..."
    With Range(Cells(1, 1), Cells(maxR, maxC))

    .Interior.ColorIndex = 19
    With .Borders(xlEdgeTop)
    .LineStyle = xlContinuous
    .Weight = xlHairline
    End With
    With .Borders(xlEdgeRight)
    .LineStyle = xlContinuous
    .Weight = xlHairline
    End With
    With .Borders(xlEdgeLeft)
    .LineStyle = xlContinuous
    .Weight = xlHairline
    End With
    With .Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .Weight = xlHairline
    End With
    On Error Resume Next
    With .Borders(xlInsideHorizontal)
    .LineStyle = xlContinuous
    .Weight = xlHairline
    End With
    With .Borders(xlInsideVertical)
    .LineStyle = xlContinuous
    .Weight = xlHairline
    End With
    On Error GoTo 0
    End With

    Columns("A:IV").ColumnWidth = 20
    rptWB.Saved = True
    If DiffCount = 0 Then

    rptWB.Close False
    End If

    Set rptWB = Nothing

    Application.StatusBar = False
    Application.ScreenUpdating = True
    MsgBox DiffCount & " cells contain different formulas!", vbInformation, _
    "Compare " & ws1.Name & " with " & ws2.Name
    End Sub

    Sub TestCompareWorksheets()
    ' compare two different worksheets in the active workbook
    CompareWorksheets Worksheets("Data1"), Worksheets("Data2")
    ' compare two different worksheets in two different workbooks
    'CompareWorksheets ActiveWorkbook.Worksheets("Sheet1"), _
    Workbooks("WorkBookName.xls").Worksheets("Sheet2")
    End Sub
    [/vba]
    ____________________________________________
    Nihil simul inventum est et perfectum

    Abusus non tollit usum

    Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
    James Thurber

  5. #5
    Thank!! Do you know how to copy the first two columns (they are similar in the two sheets) into the new one?

    THANKS!!

    [QUOTE=xld]Oops., I thought you were looking for full code, didn't realise you had some, I just eyeballed the data

  6. #6
    Distinguished Lord of VBAX VBAX Grand Master Bob Phillips's Avatar
    Joined
    Apr 2005
    Posts
    25,443
    Location
    Doesn't my code do that?
    ____________________________________________
    Nihil simul inventum est et perfectum

    Abusus non tollit usum

    Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
    James Thurber

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •