PDA

View Full Version : VBA Help



Actuary1010
07-18-2011, 06:12 AM
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!!

xld
07-18-2011, 07:36 AM
Isn't every row different in one of the columns?

Actuary1010
07-18-2011, 08:12 AM
No, actually, they are not. Try to run the macro and you will see that similar cells will be blank in the new worksheet.


Isn't every row different in one of the columns?

xld
07-18-2011, 09:17 AM
Oops., I thought you were looking for full code, didn't realise you had some, I just eyeballed the data



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

Actuary1010
07-18-2011, 09:46 AM
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

xld
07-18-2011, 09:50 AM
Doesn't my code do that?