R
Rich
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
1")
.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
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
1").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