ExcelBanter

ExcelBanter (https://www.excelbanter.com/)
-   Excel Programming (https://www.excelbanter.com/excel-programming/)
-   -   Compare Worksheet's (https://www.excelbanter.com/excel-programming/280758-compare-worksheets.html)

Rich[_19_]
Compare Worksheet's
 
Hello,

This is my first post here. I am just starting to venture into
learning VBA. So far I have been learning from recording macros and
looking at the code created, reading a VBA book, and looking through
the messages on this board.

I am using the "Compare" from Bill Manville &. Myrna Larson at
http://www.cpearson.com/excel/downloads for a base to build on. What
I need to do is run the compare and when it outputs the results to the
new sheet. In the address column. Instead of having the cell
address. I would like to have the value in Column A for the rows that
differ's.

Here is a sample of the sheets I am comparing (It is normally over
600 rows).

Workbook1
Sheet1

Column A Column B Column C Column D Column E
NODE_NAME BACKUP_MB BACKUP_COPY_MB ARCHIVE_MB ARCHIVE_COPY_MB
SAPPRD-DB2 11893552 11675754 23659 23659
SAPTST-DB2 9376426 9169713 19603 19603
SAPQAS-DB2 9326545 9109666 2374 2374
CORPPSQL03-SQL-W 3737282 3737282 0 0


Workbook2
Sheet1

Column A Column B Column C Column D Column E
NODE_NAME BACKUP_MB BACKUP_COPY_MB ARCHIVE_MB ARCHIVE_COPY_MB
SAPPRD-DB2 11893552 11675758 23659 23659
SAPTST-DB2 9376426 9169713 19605 19603
SAPQAS-DB2 9326546 9109666 2376 2374
CORPPSQL03-SQL-W 3737282 3737282 1 2


Compare Results

Column A Column B Column C Column D
Address Difference [Workbook1.xls]Sheet1 [Workbook2.xls]Sheet1
$C$2 Value 11675754 11675758
$D$3 Value 19603 19605
$B$4 Value 9326545 9326546
$D$4 Value 2374 2376
$D$5 Value 0 1
$E$5 Value 0 2



The Compare results I would like to have would look like this:

Column A Column B Column C Column D
Address Difference [Workbook1.xls]Sheet1 [Workbook2.xls]Sheet1
SAPPRD-DB2 Value 11675754 11675758
SAPTST-DB2 Value 19603 19605
SAPQAS-DB2 Value 9326545 9326546
SAPQAS-DB2 Value 2374 2376
CORPPSQL03-SQL-W Value 0 1
CORPPSQL03-SQL-W Value 0 2


This is the code I am using:

Option Explicit
Option Base 1
Option Compare Text

Private mMaxRows As Long
Private mLastUsedRow As Long

Private mDifference As Long
Private mCell1 As Range
Private mWhat As Variant
Private mV1 As Variant
Private mV2 As Variant

Private mBuffer() As Variant
Const MAX_ARY As Long = 500
Private mBufferPtr As Long

Public Sub Compare()
Dim WSNames() As String
Dim NumSheets As Long
Dim i As Long
Dim CompareWhat As Long
Dim FormatDiffs As Boolean
Dim WS1 As Worksheet, WS2 As Worksheet
Dim sBookName As String, sSheetname As String

ReDim WSNames(0 To 0)
NumSheets = GetSheetNames(WSNames())
If NumSheets = 0 Then
MsgBox "Did not find any worksheets!", vbOKOnly
Exit Sub
End If

Load frmCompare
With frmCompare
'initialize the form
'combo boxes have events -- don't fire them now
Application.EnableEvents = False

.cboSheet1.Clear
.cboSheet2.Clear
For i = 0 To NumSheets - 1
.cboSheet1.AddItem WSNames(i), i
.cboSheet2.AddItem WSNames(i), i
Next i
Erase WSNames()

.cboSheet1.ListIndex = -1
.cboSheet2.ListIndex = -1
.optFormulas.Value = True
.chkFormatDiffs.Value = False
.cmdOK.Enabled = False
.Tag = Empty
Application.EnableEvents = True

'display it
.Show
If .Tag = False Then Exit Sub

'retrieve the sheet names and options
ParseDisplayName .cboSheet1.Value, sBookName, sSheetname
Set WS1 = Workbooks(sBookName).Worksheets(sSheetname)
ParseDisplayName .cboSheet2.Value, sBookName, sSheetname
Set WS2 = Workbooks(sBookName).Worksheets(sSheetname)

Select Case True
Case .optFormulas: CompareWhat = 1
Case .optValues: CompareWhat = 2
Case .optEither: CompareWhat = 3
End Select

FormatDiffs = (.chkFormatDiffs = True)
End With

DoEvents
Unload frmCompare

CompareSheets WS1, WS2, CompareWhat, FormatDiffs
Set WS1 = Nothing
Set WS2 = Nothing

End Sub

Private Function GetSheetNames(SheetNames() As String) As Long
Dim WB As Workbook, WS As Worksheet
Dim Max As Long
Dim N As Long
Dim BookName As String

Max = Workbooks.Count * 10
ReDim SheetNames(0 To Max)

N = -1
For Each WB In Workbooks
If WB.Name < ThisWorkbook.Name Then
BookName = "[" & WB.Name & "]"
For Each WS In WB.Worksheets
If WS.Visible = True And WS.ProtectContents = False Then
N = N + 1
If N Max Then
Max = Max + 10
ReDim Preserve SheetNames(0 To Max)
End If
SheetNames(N) = BookName & WS.Name
End If 'visible, not protected
Next WS
End If 'not ThisWorkbook
Next WB

If N = 0 Then
ReDim Preserve SheetNames(0 To N)
ShellSort SheetNames()
Else
ReDim SheetNames(0 To 0)
End If
GetSheetNames = N + 1

End Function 'GetSheetNames

Private Sub ShellSort(DataArray() As String)
Dim ArrayValue As String
Dim Min As Long, Max As Long
Dim N As Long, h As Long
Dim i As Long, j As Long, p As Long

Min = LBound(DataArray)
Max = UBound(DataArray)
N = Max - Min + 1
h = 1
Do
h = h * 3 + 1
Loop While h <= N

Do
h = h \ 3
For i = Min + h To Max
ArrayValue = DataArray(i)
For j = i - h To Min Step -h
If DataArray(j) ArrayValue Then
DataArray(j + h) = DataArray(j)
Else
Exit For
End If
Next j
DataArray(j + h) = ArrayValue
Next i
Loop While h 1

End Sub 'ShellSort

Private Sub ParseDisplayName(DisplayName As String, _
BookName As String, SheetName As String)
Dim b As Long
b = InStr(DisplayName, "]")
BookName = Mid$(DisplayName, 2, b - 2)
SheetName = Mid$(DisplayName, b + 1)
End Sub 'ParseDisplayName

Private Sub CompareSheets(WS1 As Worksheet, WS2 As Worksheet, _
CompareWhat As Long, IncludeFormatDiffs As Boolean)
Dim SaveEvents As Long, SaveCalc As Long
Dim Name1 As String, Name2 As String
Dim LastRow As Long, LastCol As Long
Dim iRow As Long, iCol As Long
Dim Cell2 As Range

With Application
.ScreenUpdating = False
SaveEvents = .EnableEvents
.EnableEvents = False
SaveCalc = .Calculation
.Calculation = xlCalculationManual
End With

'open new workbook with one sheet to hold results
Workbooks.Add xlWBATWorksheet
Name1 = "[" & WS1.Parent.Name & "]" & WS1.Name
Name2 = "[" & WS2.Parent.Name & "]" & WS2.Name

With Range("A1:D1")
.Value = Array("Address", "Difference", Name1, Name2)
.Font.Bold = True
.Borders(xlEdgeBottom).LineStyle = xlContinuous
End With

mMaxRows = Rows.Count
mLastUsedRow = 1

mWhat = Array("Formula", "Value", "Numberformat")

ReDim mBuffer(1 To MAX_ARY, 1 To 4) As Variant
mBufferPtr = 0

LastRow = Application.Max( _
WS1.Range("A1").SpecialCells(xlLastCell).Row, _
WS2.Range("A1").SpecialCells(xlLastCell).Row)
LastCol = Application.Max( _
WS1.Range("A1").SpecialCells(xlLastCell).Column, _
WS2.Range("A1").SpecialCells(xlLastCell).Column)

For iRow = 1 To LastRow
For iCol = 1 To LastCol

Set mCell1 = WS1.Cells(iRow, iCol)
Set Cell2 = WS2.Cells(iRow, iCol)

mDifference = 0

Select Case CompareWhat
Case 1: CompareFormulas mCell1, Cell2
Case 2: CompareValues mCell1, Cell2
Case 3: CompareBoth mCell1, Cell2
End Select

If mDifference = 0 And IncludeFormatDiffs = True Then
If mCell1.NumberFormat < Cell2.NumberFormat Then
mDifference = 3
mV1 = " " & mCell1.NumberFormat
mV2 = " " & Cell2.NumberFormat
End If
End If

If mDifference Then NoteError

If mLastUsedRow = mMaxRows Then
MsgBox "Too many differences", vbExclamation + vbOKOnly
GoTo Done
End If
Next iCol
Next iRow

WriteToWorksheet 'write anything left in buffer to worksheet

Done:
Set mCell1 = Nothing
Erase mBuffer()

If mLastUsedRow = 1 Then
MsgBox "No differences found!", vbOKOnly, "NO DIFFERENCES"
ActiveWorkbook.Close SaveChanges:=False
Else
With ActiveSheet.UsedRange.Columns
.AutoFit
.HorizontalAlignment = xlLeft
End With
End If

With Application
.Calculation = SaveCalc
.EnableEvents = SaveEvents
.ScreenUpdating = True
End With
End Sub 'CompareSheets

Private Sub CompareFormulas(Cell1 As Range, Cell2 As Range)
Dim F1 As Boolean, F2 As Boolean

mV1 = Cell1.Formula
mV2 = Cell2.Formula

If mV1 < mV2 Then
F1 = Cell1.HasFormula
F2 = Cell2.HasFormula

'1 indicates a formula difference, 2 a value difference
mDifference = (F1 Or F2) + 2

If F1 = False Then mV1 = Cell1.Value
If F2 = False Then mV2 = Cell2.Value

End If

End Sub 'compare formulas only

Private Sub CompareValues(Cell1 As Range, Cell2 As Range)
mV1 = Cell1.Value
mV2 = Cell2.Value
If TypeName(mV1) < TypeName(mV2) Then
mDifference = 2
ElseIf mV1 < mV2 Then
mDifference = 2
End If
End Sub 'compare values only

Private Sub CompareBoth(Cell1 As Range, Cell2 As Range)
CompareFormulas Cell1, Cell2
If mDifference = 0 Then CompareValues Cell1, Cell2
End Sub 'compare both

Private Sub NoteError()
Dim Eq As String, Sp As String
Eq = "="
Sp = " "

If mBufferPtr = MAX_ARY Then WriteToWorksheet

If Not IsError(mV1) Then
If Left$(mV1, 1) = Eq Then
mV1 = Sp & mV1
End If
End If

If Not IsError(mV2) Then
If Left$(mV2, 1) = Eq Then
mV2 = Sp & mV2
End If
End If

mBufferPtr = mBufferPtr + 1
mBuffer(mBufferPtr, 1) = mCell1.Address
mBuffer(mBufferPtr, 2) = mWhat(mDifference)
mBuffer(mBufferPtr, 3) = mV1
mBuffer(mBufferPtr, 4) = mV2
End Sub 'NoteError

Private Sub WriteToWorksheet()
Dim RowsLeft As Long

If mBufferPtr = 0 Then Exit Sub 'nothing to write

'will all entries fit? if not, write as many as possible
RowsLeft = mMaxRows - mLastUsedRow
If RowsLeft < mBufferPtr Then mBufferPtr = RowsLeft

Cells(mLastUsedRow + 1, 1).Resize(mBufferPtr, 4).Value = mBuffer()
mLastUsedRow = mLastUsedRow + mBufferPtr
mBufferPtr = 0
End Sub


Thanks for any help you can provide.

Rich

Tom Ogilvy
Compare Worksheet's
 
Private Sub NoteError()
Dim Eq As String, Sp As String
Eq = "="
Sp = " "

If mBufferPtr = MAX_ARY Then WriteToWorksheet

If Not IsError(mV1) Then
If Left$(mV1, 1) = Eq Then
mV1 = Sp & mV1
End If
End If

If Not IsError(mV2) Then
If Left$(mV2, 1) = Eq Then
mV2 = Sp & mV2
End If
End If

mBufferPtr = mBufferPtr + 1
' change he
' mBuffer(mBufferPtr, 1) = mCell1.Address
mBuffer(mBufferPtr,1) = mCell1.parent.Cells(mCell1.row,1).Value
mBuffer(mBufferPtr, 2) = mWhat(mDifference)
mBuffer(mBufferPtr, 3) = mV1
mBuffer(mBufferPtr, 4) = mV2
End Sub 'NoteError


That would be my best guess, although I haven't run it to test it.

--
Regards,
Tom Ogilvy

"Rich" wrote in message
m...
Hello,

This is my first post here. I am just starting to venture into
learning VBA. So far I have been learning from recording macros and
looking at the code created, reading a VBA book, and looking through
the messages on this board.

I am using the "Compare" from Bill Manville &. Myrna Larson at
http://www.cpearson.com/excel/downloads for a base to build on. What
I need to do is run the compare and when it outputs the results to the
new sheet. In the address column. Instead of having the cell
address. I would like to have the value in Column A for the rows that
differ's.

Here is a sample of the sheets I am comparing (It is normally over
600 rows).

Workbook1
Sheet1

Column A Column B Column C Column D Column E
NODE_NAME BACKUP_MB BACKUP_COPY_MB ARCHIVE_MB ARCHIVE_COPY_MB
SAPPRD-DB2 11893552 11675754 23659 23659
SAPTST-DB2 9376426 9169713 19603 19603
SAPQAS-DB2 9326545 9109666 2374 2374
CORPPSQL03-SQL-W 3737282 3737282 0 0


Workbook2
Sheet1

Column A Column B Column C Column D Column E
NODE_NAME BACKUP_MB BACKUP_COPY_MB ARCHIVE_MB ARCHIVE_COPY_MB
SAPPRD-DB2 11893552 11675758 23659 23659
SAPTST-DB2 9376426 9169713 19605 19603
SAPQAS-DB2 9326546 9109666 2376 2374
CORPPSQL03-SQL-W 3737282 3737282 1 2


Compare Results

Column A Column B Column C Column D
Address Difference [Workbook1.xls]Sheet1 [Workbook2.xls]Sheet1
$C$2 Value 11675754 11675758
$D$3 Value 19603 19605
$B$4 Value 9326545 9326546
$D$4 Value 2374 2376
$D$5 Value 0 1
$E$5 Value 0 2



The Compare results I would like to have would look like this:

Column A Column B Column C Column D
Address Difference [Workbook1.xls]Sheet1 [Workbook2.xls]Sheet1
SAPPRD-DB2 Value 11675754 11675758
SAPTST-DB2 Value 19603 19605
SAPQAS-DB2 Value 9326545 9326546
SAPQAS-DB2 Value 2374 2376
CORPPSQL03-SQL-W Value 0 1
CORPPSQL03-SQL-W Value 0 2


This is the code I am using:

Option Explicit
Option Base 1
Option Compare Text

Private mMaxRows As Long
Private mLastUsedRow As Long

Private mDifference As Long
Private mCell1 As Range
Private mWhat As Variant
Private mV1 As Variant
Private mV2 As Variant

Private mBuffer() As Variant
Const MAX_ARY As Long = 500
Private mBufferPtr As Long

Public Sub Compare()
Dim WSNames() As String
Dim NumSheets As Long
Dim i As Long
Dim CompareWhat As Long
Dim FormatDiffs As Boolean
Dim WS1 As Worksheet, WS2 As Worksheet
Dim sBookName As String, sSheetname As String

ReDim WSNames(0 To 0)
NumSheets = GetSheetNames(WSNames())
If NumSheets = 0 Then
MsgBox "Did not find any worksheets!", vbOKOnly
Exit Sub
End If

Load frmCompare
With frmCompare
'initialize the form
'combo boxes have events -- don't fire them now
Application.EnableEvents = False

.cboSheet1.Clear
.cboSheet2.Clear
For i = 0 To NumSheets - 1
.cboSheet1.AddItem WSNames(i), i
.cboSheet2.AddItem WSNames(i), i
Next i
Erase WSNames()

.cboSheet1.ListIndex = -1
.cboSheet2.ListIndex = -1
.optFormulas.Value = True
.chkFormatDiffs.Value = False
.cmdOK.Enabled = False
.Tag = Empty
Application.EnableEvents = True

'display it
.Show
If .Tag = False Then Exit Sub

'retrieve the sheet names and options
ParseDisplayName .cboSheet1.Value, sBookName, sSheetname
Set WS1 = Workbooks(sBookName).Worksheets(sSheetname)
ParseDisplayName .cboSheet2.Value, sBookName, sSheetname
Set WS2 = Workbooks(sBookName).Worksheets(sSheetname)

Select Case True
Case .optFormulas: CompareWhat = 1
Case .optValues: CompareWhat = 2
Case .optEither: CompareWhat = 3
End Select

FormatDiffs = (.chkFormatDiffs = True)
End With

DoEvents
Unload frmCompare

CompareSheets WS1, WS2, CompareWhat, FormatDiffs
Set WS1 = Nothing
Set WS2 = Nothing

End Sub

Private Function GetSheetNames(SheetNames() As String) As Long
Dim WB As Workbook, WS As Worksheet
Dim Max As Long
Dim N As Long
Dim BookName As String

Max = Workbooks.Count * 10
ReDim SheetNames(0 To Max)

N = -1
For Each WB In Workbooks
If WB.Name < ThisWorkbook.Name Then
BookName = "[" & WB.Name & "]"
For Each WS In WB.Worksheets
If WS.Visible = True And WS.ProtectContents = False Then
N = N + 1
If N Max Then
Max = Max + 10
ReDim Preserve SheetNames(0 To Max)
End If
SheetNames(N) = BookName & WS.Name
End If 'visible, not protected
Next WS
End If 'not ThisWorkbook
Next WB

If N = 0 Then
ReDim Preserve SheetNames(0 To N)
ShellSort SheetNames()
Else
ReDim SheetNames(0 To 0)
End If
GetSheetNames = N + 1

End Function 'GetSheetNames

Private Sub ShellSort(DataArray() As String)
Dim ArrayValue As String
Dim Min As Long, Max As Long
Dim N As Long, h As Long
Dim i As Long, j As Long, p As Long

Min = LBound(DataArray)
Max = UBound(DataArray)
N = Max - Min + 1
h = 1
Do
h = h * 3 + 1
Loop While h <= N

Do
h = h \ 3
For i = Min + h To Max
ArrayValue = DataArray(i)
For j = i - h To Min Step -h
If DataArray(j) ArrayValue Then
DataArray(j + h) = DataArray(j)
Else
Exit For
End If
Next j
DataArray(j + h) = ArrayValue
Next i
Loop While h 1

End Sub 'ShellSort

Private Sub ParseDisplayName(DisplayName As String, _
BookName As String, SheetName As String)
Dim b As Long
b = InStr(DisplayName, "]")
BookName = Mid$(DisplayName, 2, b - 2)
SheetName = Mid$(DisplayName, b + 1)
End Sub 'ParseDisplayName

Private Sub CompareSheets(WS1 As Worksheet, WS2 As Worksheet, _
CompareWhat As Long, IncludeFormatDiffs As Boolean)
Dim SaveEvents As Long, SaveCalc As Long
Dim Name1 As String, Name2 As String
Dim LastRow As Long, LastCol As Long
Dim iRow As Long, iCol As Long
Dim Cell2 As Range

With Application
.ScreenUpdating = False
SaveEvents = .EnableEvents
.EnableEvents = False
SaveCalc = .Calculation
.Calculation = xlCalculationManual
End With

'open new workbook with one sheet to hold results
Workbooks.Add xlWBATWorksheet
Name1 = "[" & WS1.Parent.Name & "]" & WS1.Name
Name2 = "[" & WS2.Parent.Name & "]" & WS2.Name

With Range("A1:D1")
.Value = Array("Address", "Difference", Name1, Name2)
.Font.Bold = True
.Borders(xlEdgeBottom).LineStyle = xlContinuous
End With

mMaxRows = Rows.Count
mLastUsedRow = 1

mWhat = Array("Formula", "Value", "Numberformat")

ReDim mBuffer(1 To MAX_ARY, 1 To 4) As Variant
mBufferPtr = 0

LastRow = Application.Max( _
WS1.Range("A1").SpecialCells(xlLastCell).Row, _
WS2.Range("A1").SpecialCells(xlLastCell).Row)
LastCol = Application.Max( _
WS1.Range("A1").SpecialCells(xlLastCell).Column, _
WS2.Range("A1").SpecialCells(xlLastCell).Column)

For iRow = 1 To LastRow
For iCol = 1 To LastCol

Set mCell1 = WS1.Cells(iRow, iCol)
Set Cell2 = WS2.Cells(iRow, iCol)

mDifference = 0

Select Case CompareWhat
Case 1: CompareFormulas mCell1, Cell2
Case 2: CompareValues mCell1, Cell2
Case 3: CompareBoth mCell1, Cell2
End Select

If mDifference = 0 And IncludeFormatDiffs = True Then
If mCell1.NumberFormat < Cell2.NumberFormat Then
mDifference = 3
mV1 = " " & mCell1.NumberFormat
mV2 = " " & Cell2.NumberFormat
End If
End If

If mDifference Then NoteError

If mLastUsedRow = mMaxRows Then
MsgBox "Too many differences", vbExclamation + vbOKOnly
GoTo Done
End If
Next iCol
Next iRow

WriteToWorksheet 'write anything left in buffer to worksheet

Done:
Set mCell1 = Nothing
Erase mBuffer()

If mLastUsedRow = 1 Then
MsgBox "No differences found!", vbOKOnly, "NO DIFFERENCES"
ActiveWorkbook.Close SaveChanges:=False
Else
With ActiveSheet.UsedRange.Columns
.AutoFit
.HorizontalAlignment = xlLeft
End With
End If

With Application
.Calculation = SaveCalc
.EnableEvents = SaveEvents
.ScreenUpdating = True
End With
End Sub 'CompareSheets

Private Sub CompareFormulas(Cell1 As Range, Cell2 As Range)
Dim F1 As Boolean, F2 As Boolean

mV1 = Cell1.Formula
mV2 = Cell2.Formula

If mV1 < mV2 Then
F1 = Cell1.HasFormula
F2 = Cell2.HasFormula

'1 indicates a formula difference, 2 a value difference
mDifference = (F1 Or F2) + 2

If F1 = False Then mV1 = Cell1.Value
If F2 = False Then mV2 = Cell2.Value

End If

End Sub 'compare formulas only

Private Sub CompareValues(Cell1 As Range, Cell2 As Range)
mV1 = Cell1.Value
mV2 = Cell2.Value
If TypeName(mV1) < TypeName(mV2) Then
mDifference = 2
ElseIf mV1 < mV2 Then
mDifference = 2
End If
End Sub 'compare values only

Private Sub CompareBoth(Cell1 As Range, Cell2 As Range)
CompareFormulas Cell1, Cell2
If mDifference = 0 Then CompareValues Cell1, Cell2
End Sub 'compare both

Private Sub NoteError()
Dim Eq As String, Sp As String
Eq = "="
Sp = " "

If mBufferPtr = MAX_ARY Then WriteToWorksheet

If Not IsError(mV1) Then
If Left$(mV1, 1) = Eq Then
mV1 = Sp & mV1
End If
End If

If Not IsError(mV2) Then
If Left$(mV2, 1) = Eq Then
mV2 = Sp & mV2
End If
End If

mBufferPtr = mBufferPtr + 1
mBuffer(mBufferPtr, 1) = mCell1.Address
mBuffer(mBufferPtr, 2) = mWhat(mDifference)
mBuffer(mBufferPtr, 3) = mV1
mBuffer(mBufferPtr, 4) = mV2
End Sub 'NoteError

Private Sub WriteToWorksheet()
Dim RowsLeft As Long

If mBufferPtr = 0 Then Exit Sub 'nothing to write

'will all entries fit? if not, write as many as possible
RowsLeft = mMaxRows - mLastUsedRow
If RowsLeft < mBufferPtr Then mBufferPtr = RowsLeft

Cells(mLastUsedRow + 1, 1).Resize(mBufferPtr, 4).Value = mBuffer()
mLastUsedRow = mLastUsedRow + mBufferPtr
mBufferPtr = 0
End Sub


Thanks for any help you can provide.

Rich

Myrna Larson[_3_]
Compare Worksheet's
 
It looks good to me, Tom, though I didn't try it either <g.


On Tue, 28 Oct 2003 08:04:41 -0500, "Tom Ogilvy" wrote:

Private Sub NoteError()
Dim Eq As String, Sp As String
Eq = "="
Sp = " "

If mBufferPtr = MAX_ARY Then WriteToWorksheet

If Not IsError(mV1) Then
If Left$(mV1, 1) = Eq Then
mV1 = Sp & mV1
End If
End If

If Not IsError(mV2) Then
If Left$(mV2, 1) = Eq Then
mV2 = Sp & mV2
End If
End If

mBufferPtr = mBufferPtr + 1
' change he
' mBuffer(mBufferPtr, 1) = mCell1.Address
mBuffer(mBufferPtr,1) = mCell1.parent.Cells(mCell1.row,1).Value
mBuffer(mBufferPtr, 2) = mWhat(mDifference)
mBuffer(mBufferPtr, 3) = mV1
mBuffer(mBufferPtr, 4) = mV2
End Sub 'NoteError


That would be my best guess, although I haven't run it to test it.

Rich[_19_]
Compare Worksheet's
 
Thank you both for all your help. It works perfectly.

Regards,

Rich


Myrna Larson wrote in message . ..
It looks good to me, Tom, though I didn't try it either <g.


On Tue, 28 Oct 2003 08:04:41 -0500, "Tom Ogilvy" wrote:

Private Sub NoteError()
Dim Eq As String, Sp As String
Eq = "="
Sp = " "

If mBufferPtr = MAX_ARY Then WriteToWorksheet

If Not IsError(mV1) Then
If Left$(mV1, 1) = Eq Then
mV1 = Sp & mV1
End If
End If

If Not IsError(mV2) Then
If Left$(mV2, 1) = Eq Then
mV2 = Sp & mV2
End If
End If

mBufferPtr = mBufferPtr + 1
' change he
' mBuffer(mBufferPtr, 1) = mCell1.Address
mBuffer(mBufferPtr,1) = mCell1.parent.Cells(mCell1.row,1).Value
mBuffer(mBufferPtr, 2) = mWhat(mDifference)
mBuffer(mBufferPtr, 3) = mV1
mBuffer(mBufferPtr, 4) = mV2
End Sub 'NoteError


That would be my best guess, although I haven't run it to test it.

Rich[_19_]
Compare Worksheet's
 
Would it be possible to add a extra column on the results sheet next
to "Address" and have it display the column heading? Using the
information in my first post.

The Compare results would then look like this:

Column A Column B Column C Column D Column E
Address Column Difference [WB1]Sheet1 [WB2]Sheet1
SAPPRD-DB2 BACKUP_COPY_MB Value 11675754 11675758
SAPTST-DB2 ARCHIVE_MB Value 19603 19605
SAPQAS-DB2 BACKUP_MB Value 9326545 9326546
SAPQAS-DB2 ARCHIVE_MB Value 2374 2376
CORPPSQL03-SQL-W ARCHIVE_MB Value 0 1
CORPPSQL03-SQL-W ARCHIVE_COPY_MBValue 0 2

Thank you for any help.

Regards,
Rich





"Tom Ogilvy" wrote in message ...
Private Sub NoteError()
Dim Eq As String, Sp As String
Eq = "="
Sp = " "

If mBufferPtr = MAX_ARY Then WriteToWorksheet

If Not IsError(mV1) Then
If Left$(mV1, 1) = Eq Then
mV1 = Sp & mV1
End If
End If

If Not IsError(mV2) Then
If Left$(mV2, 1) = Eq Then
mV2 = Sp & mV2
End If
End If

mBufferPtr = mBufferPtr + 1
' change he
' mBuffer(mBufferPtr, 1) = mCell1.Address
mBuffer(mBufferPtr,1) = mCell1.parent.Cells(mCell1.row,1).Value
mBuffer(mBufferPtr, 2) = mWhat(mDifference)
mBuffer(mBufferPtr, 3) = mV1
mBuffer(mBufferPtr, 4) = mV2
End Sub 'NoteError


That would be my best guess, although I haven't run it to test it.

--
Regards,
Tom Ogilvy

"Rich" wrote in message
m...
Hello,

This is my first post here. I am just starting to venture into
learning VBA. So far I have been learning from recording macros and
looking at the code created, reading a VBA book, and looking through
the messages on this board.

I am using the "Compare" from Bill Manville &. Myrna Larson at
http://www.cpearson.com/excel/downloads for a base to build on. What
I need to do is run the compare and when it outputs the results to the
new sheet. In the address column. Instead of having the cell
address. I would like to have the value in Column A for the rows that
differ's.

Here is a sample of the sheets I am comparing (It is normally over
600 rows).

Workbook1
Sheet1

Column A Column B Column C Column D Column E
NODE_NAME BACKUP_MB BACKUP_COPY_MB ARCHIVE_MB ARCHIVE_COPY_MB
SAPPRD-DB2 11893552 11675754 23659 23659
SAPTST-DB2 9376426 9169713 19603 19603
SAPQAS-DB2 9326545 9109666 2374 2374
CORPPSQL03-SQL-W 3737282 3737282 0 0


Workbook2
Sheet1

Column A Column B Column C Column D Column E
NODE_NAME BACKUP_MB BACKUP_COPY_MB ARCHIVE_MB ARCHIVE_COPY_MB
SAPPRD-DB2 11893552 11675758 23659 23659
SAPTST-DB2 9376426 9169713 19605 19603
SAPQAS-DB2 9326546 9109666 2376 2374
CORPPSQL03-SQL-W 3737282 3737282 1 2


Compare Results

Column A Column B Column C Column D
Address Difference [Workbook1.xls]Sheet1 [Workbook2.xls]Sheet1
$C$2 Value 11675754 11675758
$D$3 Value 19603 19605
$B$4 Value 9326545 9326546
$D$4 Value 2374 2376
$D$5 Value 0 1
$E$5 Value 0 2



The Compare results I would like to have would look like this:

Column A Column B Column C Column D
Address Difference [Workbook1.xls]Sheet1 [Workbook2.xls]Sheet1
SAPPRD-DB2 Value 11675754 11675758
SAPTST-DB2 Value 19603 19605
SAPQAS-DB2 Value 9326545 9326546
SAPQAS-DB2 Value 2374 2376
CORPPSQL03-SQL-W Value 0 1
CORPPSQL03-SQL-W Value 0 2


This is the code I am using:

Option Explicit
Option Base 1
Option Compare Text

Private mMaxRows As Long
Private mLastUsedRow As Long

Private mDifference As Long
Private mCell1 As Range
Private mWhat As Variant
Private mV1 As Variant
Private mV2 As Variant

Private mBuffer() As Variant
Const MAX_ARY As Long = 500
Private mBufferPtr As Long

Public Sub Compare()
Dim WSNames() As String
Dim NumSheets As Long
Dim i As Long
Dim CompareWhat As Long
Dim FormatDiffs As Boolean
Dim WS1 As Worksheet, WS2 As Worksheet
Dim sBookName As String, sSheetname As String

ReDim WSNames(0 To 0)
NumSheets = GetSheetNames(WSNames())
If NumSheets = 0 Then
MsgBox "Did not find any worksheets!", vbOKOnly
Exit Sub
End If

Load frmCompare
With frmCompare
'initialize the form
'combo boxes have events -- don't fire them now
Application.EnableEvents = False

.cboSheet1.Clear
.cboSheet2.Clear
For i = 0 To NumSheets - 1
.cboSheet1.AddItem WSNames(i), i
.cboSheet2.AddItem WSNames(i), i
Next i
Erase WSNames()

.cboSheet1.ListIndex = -1
.cboSheet2.ListIndex = -1
.optFormulas.Value = True
.chkFormatDiffs.Value = False
.cmdOK.Enabled = False
.Tag = Empty
Application.EnableEvents = True

'display it
.Show
If .Tag = False Then Exit Sub

'retrieve the sheet names and options
ParseDisplayName .cboSheet1.Value, sBookName, sSheetname
Set WS1 = Workbooks(sBookName).Worksheets(sSheetname)
ParseDisplayName .cboSheet2.Value, sBookName, sSheetname
Set WS2 = Workbooks(sBookName).Worksheets(sSheetname)

Select Case True
Case .optFormulas: CompareWhat = 1
Case .optValues: CompareWhat = 2
Case .optEither: CompareWhat = 3
End Select

FormatDiffs = (.chkFormatDiffs = True)
End With

DoEvents
Unload frmCompare

CompareSheets WS1, WS2, CompareWhat, FormatDiffs
Set WS1 = Nothing
Set WS2 = Nothing

End Sub

Private Function GetSheetNames(SheetNames() As String) As Long
Dim WB As Workbook, WS As Worksheet
Dim Max As Long
Dim N As Long
Dim BookName As String

Max = Workbooks.Count * 10
ReDim SheetNames(0 To Max)

N = -1
For Each WB In Workbooks
If WB.Name < ThisWorkbook.Name Then
BookName = "[" & WB.Name & "]"
For Each WS In WB.Worksheets
If WS.Visible = True And WS.ProtectContents = False Then
N = N + 1
If N Max Then
Max = Max + 10
ReDim Preserve SheetNames(0 To Max)
End If
SheetNames(N) = BookName & WS.Name
End If 'visible, not protected
Next WS
End If 'not ThisWorkbook
Next WB

If N = 0 Then
ReDim Preserve SheetNames(0 To N)
ShellSort SheetNames()
Else
ReDim SheetNames(0 To 0)
End If
GetSheetNames = N + 1

End Function 'GetSheetNames

Private Sub ShellSort(DataArray() As String)
Dim ArrayValue As String
Dim Min As Long, Max As Long
Dim N As Long, h As Long
Dim i As Long, j As Long, p As Long

Min = LBound(DataArray)
Max = UBound(DataArray)
N = Max - Min + 1
h = 1
Do
h = h * 3 + 1
Loop While h <= N

Do
h = h \ 3
For i = Min + h To Max
ArrayValue = DataArray(i)
For j = i - h To Min Step -h
If DataArray(j) ArrayValue Then
DataArray(j + h) = DataArray(j)
Else
Exit For
End If
Next j
DataArray(j + h) = ArrayValue
Next i
Loop While h 1

End Sub 'ShellSort

Private Sub ParseDisplayName(DisplayName As String, _
BookName As String, SheetName As String)
Dim b As Long
b = InStr(DisplayName, "]")
BookName = Mid$(DisplayName, 2, b - 2)
SheetName = Mid$(DisplayName, b + 1)
End Sub 'ParseDisplayName

Private Sub CompareSheets(WS1 As Worksheet, WS2 As Worksheet, _
CompareWhat As Long, IncludeFormatDiffs As Boolean)
Dim SaveEvents As Long, SaveCalc As Long
Dim Name1 As String, Name2 As String
Dim LastRow As Long, LastCol As Long
Dim iRow As Long, iCol As Long
Dim Cell2 As Range

With Application
.ScreenUpdating = False
SaveEvents = .EnableEvents
.EnableEvents = False
SaveCalc = .Calculation
.Calculation = xlCalculationManual
End With

'open new workbook with one sheet to hold results
Workbooks.Add xlWBATWorksheet
Name1 = "[" & WS1.Parent.Name & "]" & WS1.Name
Name2 = "[" & WS2.Parent.Name & "]" & WS2.Name

With Range("A1:D1")
.Value = Array("Address", "Difference", Name1, Name2)
.Font.Bold = True
.Borders(xlEdgeBottom).LineStyle = xlContinuous
End With

mMaxRows = Rows.Count
mLastUsedRow = 1

mWhat = Array("Formula", "Value", "Numberformat")

ReDim mBuffer(1 To MAX_ARY, 1 To 4) As Variant
mBufferPtr = 0

LastRow = Application.Max( _
WS1.Range("A1").SpecialCells(xlLastCell).Row, _
WS2.Range("A1").SpecialCells(xlLastCell).Row)
LastCol = Application.Max( _
WS1.Range("A1").SpecialCells(xlLastCell).Column, _
WS2.Range("A1").SpecialCells(xlLastCell).Column)

For iRow = 1 To LastRow
For iCol = 1 To LastCol

Set mCell1 = WS1.Cells(iRow, iCol)
Set Cell2 = WS2.Cells(iRow, iCol)

mDifference = 0

Select Case CompareWhat
Case 1: CompareFormulas mCell1, Cell2
Case 2: CompareValues mCell1, Cell2
Case 3: CompareBoth mCell1, Cell2
End Select

If mDifference = 0 And IncludeFormatDiffs = True Then
If mCell1.NumberFormat < Cell2.NumberFormat Then
mDifference = 3
mV1 = " " & mCell1.NumberFormat
mV2 = " " & Cell2.NumberFormat
End If
End If

If mDifference Then NoteError

If mLastUsedRow = mMaxRows Then
MsgBox "Too many differences", vbExclamation + vbOKOnly
GoTo Done
End If
Next iCol
Next iRow

WriteToWorksheet 'write anything left in buffer to worksheet

Done:
Set mCell1 = Nothing
Erase mBuffer()

If mLastUsedRow = 1 Then
MsgBox "No differences found!", vbOKOnly, "NO DIFFERENCES"
ActiveWorkbook.Close SaveChanges:=False
Else
With ActiveSheet.UsedRange.Columns
.AutoFit
.HorizontalAlignment = xlLeft
End With
End If

With Application
.Calculation = SaveCalc
.EnableEvents = SaveEvents
.ScreenUpdating = True
End With
End Sub 'CompareSheets

Private Sub CompareFormulas(Cell1 As Range, Cell2 As Range)
Dim F1 As Boolean, F2 As Boolean

mV1 = Cell1.Formula
mV2 = Cell2.Formula

If mV1 < mV2 Then
F1 = Cell1.HasFormula
F2 = Cell2.HasFormula

'1 indicates a formula difference, 2 a value difference
mDifference = (F1 Or F2) + 2

If F1 = False Then mV1 = Cell1.Value
If F2 = False Then mV2 = Cell2.Value

End If

End Sub 'compare formulas only

Private Sub CompareValues(Cell1 As Range, Cell2 As Range)
mV1 = Cell1.Value
mV2 = Cell2.Value
If TypeName(mV1) < TypeName(mV2) Then
mDifference = 2
ElseIf mV1 < mV2 Then
mDifference = 2
End If
End Sub 'compare values only

Private Sub CompareBoth(Cell1 As Range, Cell2 As Range)
CompareFormulas Cell1, Cell2
If mDifference = 0 Then CompareValues Cell1, Cell2
End Sub 'compare both

Private Sub NoteError()
Dim Eq As String, Sp As String
Eq = "="
Sp = " "

If mBufferPtr = MAX_ARY Then WriteToWorksheet

If Not IsError(mV1) Then
If Left$(mV1, 1) = Eq Then
mV1 = Sp & mV1
End If
End If

If Not IsError(mV2) Then
If Left$(mV2, 1) = Eq Then
mV2 = Sp & mV2
End If
End If

mBufferPtr = mBufferPtr + 1
mBuffer(mBufferPtr, 1) = mCell1.Address
mBuffer(mBufferPtr, 2) = mWhat(mDifference)
mBuffer(mBufferPtr, 3) = mV1
mBuffer(mBufferPtr, 4) = mV2
End Sub 'NoteError

Private Sub WriteToWorksheet()
Dim RowsLeft As Long

If mBufferPtr = 0 Then Exit Sub 'nothing to write

'will all entries fit? if not, write as many as possible
RowsLeft = mMaxRows - mLastUsedRow
If RowsLeft < mBufferPtr Then mBufferPtr = RowsLeft

Cells(mLastUsedRow + 1, 1).Resize(mBufferPtr, 4).Value = mBuffer()
mLastUsedRow = mLastUsedRow + mBufferPtr
mBufferPtr = 0
End Sub


Thanks for any help you can provide.

Rich


All times are GMT +1. The time now is 07:38 AM.

Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
ExcelBanter.com