Thanks for the blog link I'll take a look at it.
Kap - 1.I used 'find' first but the problem is that my keys have \. so it doesn't work.
2.Current code does import two workbooks to one.
Thanks tho any other ideas?
In the mean time here is my code. Sorry for the length.
-------------
Dim intRowCnt As Long
Sub CompareResult()
Dim xlCalc As XlCalculation
xlCalc = Application.Calculation
Application.Calculation = xlCalculationManual
On Error GoTo CalcBack
'The macro that calls all the procedures
'ctrl t is the shortcut to run this macro
intRowCnt = Sheet4.Cells(1, 2)
'Clears expected,actual, and compare sheets in prepartion for data migration
Sheet2.Select
Call ClearAllComp
Sheet5.Select
Call ClearAllComp
Sheet3.Select
Call ClearAllComp
Call OpenExpectedData
'First using Logic Key tab finds data and copies and pastes into Actual and Expected tabs
Call OpenActualData
'Second construct key (required for comparison) for actual result
Call ConstrucKeyAct
Call ConstrucKeyExp
Application.ScreenUpdating = False
Call PopulateExp
Call DuplicatesActual
Call DuplicatesExpected
Call ExtraActuals
Application.ScreenUpdating = True
Worksheets("Compare Result").Select
Application.Calculation = xlCalc
Exit Sub
CalcBack:
Application.Calculation = xlCal
End Sub
Sub ConstrucKeyAct()
Dim xlCalc As XlCalculation
xlCalc = Application.Calculation
Application.Calculation = xlCalculationManual
On Error GoTo CalcBack
Dim intRow As Long
Dim intCol As Long
Dim strKey As String
intRow = 3
intCol = 1
Sheet5.Select
Call ClearCellA
'Constructs key off of what is specified in Sheet 4 or Logical Key tab where which fields you want in the key
'Are specified by numbers and listed above each column in Expected and Actual sheets in row 1
While (Sheet5.Cells(intRow, intCol + 1) <> "")
strKey = Sheet5.Cells(intRow, intCol + Sheet4.Cells(2, 4)) _
& Sheet5.Cells(intRow, intCol + Sheet4.Cells(3, 4)) & Sheet5.Cells(intRow, intCol + Sheet4.Cells(4, 4)) _
& Sheet5.Cells(intRow, intCol + Sheet4.Cells(5, 4)) & Sheet5.Cells(intRow, intCol + Sheet4.Cells(6, 4)) _
& Sheet5.Cells(intRow, intCol + Sheet4.Cells(7, 4)) & Sheet5.Cells(intRow, intCol + Sheet4.Cells(8, 4)) _
& Sheet5.Cells(intRow, intCol + Sheet4.Cells(9, 4)) & Sheet5.Cells(intRow, intCol + Sheet4.Cells(10, 4)) _
& Sheet5.Cells(intRow, intCol + Sheet4.Cells(11, 4)) & Sheet5.Cells(intRow, intCol + Sheet4.Cells(12, 4)) _
& Sheet5.Cells(intRow, intCol + Sheet4.Cells(13, 4)) & Sheet5.Cells(intRow, intCol + Sheet4.Cells(14, 4)) _
& Sheet5.Cells(intRow, intCol + Sheet4.Cells(15, 4)) & Sheet5.Cells(intRow, intCol + Sheet4.Cells(16, 4)) _
& Sheet5.Cells(intRow, intCol + Sheet4.Cells(17, 4)) & Sheet5.Cells(intRow, intCol + Sheet4.Cells(18, 4)) _
& Sheet5.Cells(intRow, intCol + Sheet4.Cells(19, 4)) & Sheet5.Cells(intRow, intCol + Sheet4.Cells(20, 4)) _
& Sheet5.Cells(intRow, intCol + Sheet4.Cells(21, 4))
Sheet5.Cells(intRow, intCol) = strKey
intRow = intRow + 1
Wend
Application.Calculation = xlCalc
Exit Sub
CalcBack:
Application.Calculation = xlCal
End Sub
Sub ConstrucKeyExp()
Dim xlCalc As XlCalculation
xlCalc = Application.Calculation
Application.Calculation = xlCalculationManual
On Error GoTo CalcBack
Dim intRow As Long
Dim intCol As Long
intRow = 3
intCol = 3
Sheet2.Select
Call ClearCellA
'Constructs key off of what is specified in Sheet 4 or Logical Key tab where which fields you want in the key
'Are specified by numbers and listed above each column in Expected and Actual sheets in row 1
While (Sheet2.Cells(intRow, intCol + 1) <> "")
Sheet2.Cells(intRow, intCol - 2) = Sheet2.Cells(intRow, intCol + Sheet4.Cells(2, 4)) _
& Sheet2.Cells(intRow, intCol + Sheet4.Cells(3, 4)) & Sheet2.Cells(intRow, intCol + Sheet4.Cells(4, 4)) _
& Sheet2.Cells(intRow, intCol + Sheet4.Cells(5, 4)) & Sheet2.Cells(intRow, intCol + Sheet4.Cells(6, 4)) _
& Sheet2.Cells(intRow, intCol + Sheet4.Cells(7, 4)) & Sheet2.Cells(intRow, intCol + Sheet4.Cells(8, 4)) _
& Sheet2.Cells(intRow, intCol + Sheet4.Cells(9, 4)) & Sheet2.Cells(intRow, intCol + Sheet4.Cells(10, 4)) _
& Sheet2.Cells(intRow, intCol + Sheet4.Cells(11, 4)) & Sheet2.Cells(intRow, intCol + Sheet4.Cells(12, 4)) _
& Sheet2.Cells(intRow, intCol + Sheet4.Cells(13, 4)) & Sheet2.Cells(intRow, intCol + Sheet4.Cells(14, 4)) _
& Sheet2.Cells(intRow, intCol + Sheet4.Cells(15, 4)) & Sheet2.Cells(intRow, intCol + Sheet4.Cells(16, 4)) _
& Sheet2.Cells(intRow, intCol + Sheet4.Cells(17, 4)) & Sheet2.Cells(intRow, intCol + Sheet4.Cells(18, 4)) _
& Sheet2.Cells(intRow, intCol + Sheet4.Cells(19, 4)) & Sheet2.Cells(intRow, intCol + Sheet4.Cells(20, 4)) _
& Sheet2.Cells(intRow, intCol + Sheet4.Cells(21, 4))
intRow = intRow + 1
Wend
Application.Calculation = xlCalc
Exit Sub
CalcBack:
Application.Calculation = xlCal
End Sub
Sub ClearCellA()
Dim xlCalc As XlCalculation
xlCalc = Application.Calculation
Application.Calculation = xlCalculationManual
On Error GoTo CalcBack
'
'Clearing cell A through 10,000 because couldn't find last data cell to clear in just column A
Range("A3:A100000").Select
Selection.ClearContents
Range("A2").Select
Application.Calculation = xlCalc
Exit Sub
CalcBack:
Application.Calculation = xlCal
End Sub
Sub PopulateExp()
Dim xlCalc As XlCalculation
xlCalc = Application.Calculation
Application.Calculation = xlCalculationManual
On Error GoTo CalcBack
'Takes expected data populates it every other row until all expected are shown in the Compare Result Sheet
Dim intExpRow As Long
Dim intCompRow As Long
Dim intCol As Long
intExpRow = 3
intCompRow = 3
intCol = 1
Sheet3.Select
intRowCnt = Sheet4.Cells(1, 2)
Call ClearAllComp
While Sheet2.Cells(intExpRow, intCol) <> ""
Sheet3.Cells(intCompRow, intCol) = "Expected"
Sheet3.Cells(intCompRow, intCol + 1) = Sheet2.Cells(intExpRow, intCol + 1)
Sheet3.Cells(intCompRow, intCol + 2) = Sheet2.Cells(intExpRow, intCol + 2)
Sheet3.Cells(intCompRow, intCol + 3) = Sheet2.Cells(intExpRow, intCol)
While (intCol <= intRowCnt)
Sheet3.Cells(intCompRow, intCol + 4) = Sheet2.Cells(intExpRow, intCol + 3).Value
intCol = intCol + 1
Wend
Sheet3.Rows(intCompRow).Select
With Selection.Interior
.ColorIndex = 34
.Pattern = xlSolid
End With
Call PopulateAct(intCompRow)
intCompRow = intCompRow + 2
intExpRow = intExpRow + 1
intCol = 1
Wend
Application.Calculation = xlCalc
Exit Sub
CalcBack:
Application.Calculation = xlCal
End Sub
Sub PopulateAct(intCompRow)
Dim xlCalc As XlCalculation
xlCalc = Application.Calculation
Application.Calculation = xlCalculationManual
On Error GoTo CalcBack
'Takes actual data populates below the expected result by using the key and the vlookup value in expected range
Dim intExpRow As Long
Dim intCol As Long
intCol = 1
Sheet3.Select
Sheet3.Cells(intCompRow + 1, intCol) = "Actual"
Sheet3.Cells(intCompRow + 1, intCol + 1) = Sheet3.Cells(intCompRow, intCol + 1)
Sheet3.Cells(intCompRow + 1, intCol + 2) = Sheet3.Cells(intCompRow, intCol + 2)
While (intCol <= intRowCnt + 1)
Sheet3.Cells(intCompRow + 1, intCol + 3) = "=VLOOKUP(D" & intCompRow & ",Actual!A1:BP150000," & (intCol) & ",FALSE)"
'WorksheetFunction.VLookup(Sheet3.Cells(intCompRow, 4), Range("Test_Result"), intCol, False)
Call CompareData(intCompRow, intCol)
intCol = intCol + 1
Wend
Application.Calculation = xlCalc
Exit Sub
CalcBack:
Application.Calculation = xlCal
End Sub
Sub CompareData(intCompRow, intCol)
Dim xlCalc As XlCalculation
xlCalc = Application.Calculation
Application.Calculation = xlCalculationManual
On Error GoTo CalcBack
'Take the actual against expected and shows the differences by color
If IsError(Sheet3.Cells(intCompRow + 1, intCol + 3).Value) Then
Sheet3.Cells(intCompRow + 1, intCol + 3) = "Actual Result Not Found"
Sheet3.Cells(intCompRow + 1, intCol + 3).Font.ColorIndex = 5
Sheet3.Cells(intCompRow + 1, intCol + 3).Font.Bold = True
Sheet3.Rows(intCompRow + 1).Interior.ColorIndex = 40
intCol = intRowCnt + 1 'To exit the while loop
Else
If Sheet3.Cells(intCompRow + 1, intCol + 3).Value = Sheet3.Cells(intCompRow, intCol + 3).Value Then
Else
Sheet3.Cells(intCompRow + 1, intCol + 3).Interior.ColorIndex = 40
Sheet3.Cells(intCompRow + 1, intCol + 3).Font.ColorIndex = 5
Sheet3.Cells(intCompRow + 1, intCol + 3).Font.Bold = True
End If
End If
Application.Calculation = xlCalc
Exit Sub
CalcBack:
Application.Calculation = xlCal
End Sub
Sub ClearAllComp()
Dim xlCalc As XlCalculation
xlCalc = Application.Calculation
Application.Calculation = xlCalculationManual
On Error GoTo CalcBack
'Selects starting at A3 to all cells that have data in it
'Then clears the data
Range("A3", Selection.SpecialCells(xlLastCell)).Select
Selection.Clear
Application.Calculation = xlCalc
Exit Sub
CalcBack:
Application.Calculation = xlCalc
End Sub
Sub OpenActualData()
Dim xlCalc As XlCalculation
xlCalc = Application.Calculation
Application.Calculation = xlCalculationManual
On Error GoTo CalcBack
'Selects starting at A3 to all cells that have data in it
'Then clears the data
' OpenActualData Macro
' Find the key with link to worksheet then copys data into cells current workbook.
currentworkbook = Worksheets("Logical Key").Range("B15")
'variable for when the spreadsheet name changes project to project
Sheets("Logical Key").Select
Range("B12").Select
Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
Range("A1", Selection.SpecialCells(xlLastCell)).Select
'In the Actual input file opens and finds all data from range A2,to last populated cell
Selection.Copy
ActiveWorkbook.Close SaveChanges:=True
Windows(currentworkbook).Activate
Sheets("Actual").Select
Range("B2").Select
ActiveSheet.Paste
Application.Calculation = xlCalc
Exit Sub
CalcBack:
Application.Calculation = xlCalc
End Sub
Sub OpenExpectedData()
Dim xlCalc As XlCalculation
xlCalc = Application.Calculation
Application.Calculation = xlCalculationManual
On Error GoTo CalcBack
' OpenExpectedData Macro
' Find the key with link to worksheet then copys data into cells current workbook.
currentworkbook = Worksheets("Logical Key").Range("B15")
'variable for when the spreadsheet name changes project to project
Sheets("Logical Key").Select
Range("B13").Select
Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
Range("A1", Selection.SpecialCells(xlLastCell)).Select
'In Expected input file opens and finds all data from range A2,to last populated cell
Selection.Copy
ActiveWorkbook.Close SaveChanges:=True
Windows(currentworkbook).Activate
Sheets("Expected").Select
Range("D2").Select
ActiveSheet.Paste
Application.Calculation = xlCalc
Exit Sub
CalcBack:
Application.Calculation = xlCalc
End Sub
Sub DuplicatesActual()
Dim xlCalc As XlCalculation
xlCalc = Application.Calculation
Application.Calculation = xlCalculationManual
On Error GoTo CalcBack
Application.Wait Now + TimeValue("0:00:01")
'Delay because the CompareData takes some time and the this procedure like to start before that loop is complete
' Conditional formats cells for Actual results by red for duplicates in the key
Sheets("Actual").Select
Columns("A:A").Select
Selection.FormatConditions.AddUniqueValues
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).DupeUnique = xlDuplicate
With Selection.FormatConditions(1).Font
.Color = -16383844
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 13551615
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Application.Calculation = xlCalc
Exit Sub
CalcBack:
Application.Calculation = xlCalc
End Sub
Sub DuplicatesExpected()
Dim xlCalc As XlCalculation
xlCalc = Application.Calculation
Application.Calculation = xlCalculationManual
On Error GoTo CalcBack
Application.Wait Now + TimeValue("0:00:01")
'Delay because the CompareData takes some time and the this procedure like to start before that loop is complete
' Conditional formats cells for Expected results by red for duplicates in the key
Sheets("Expected").Select
Columns("A:A").Select
Selection.FormatConditions.AddUniqueValues
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).DupeUnique = xlDuplicate
With Selection.FormatConditions(1).Font
.Color = -16383844
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 13551615
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Application.Calculation = xlCalc
Exit Sub
CalcBack:
Application.Calculation = xlCalc
End Sub
Sub ExtraActuals()
Dim xlCalc As XlCalculation
xlCalc = Application.Calculation
Application.Calculation = xlCalculationManual
On Error GoTo CalcBack
'This procedure is looking for the keys that are not in expected but are in Actual.
Application.Wait Now + TimeValue("0:00:02")
x = 5
'The variable to copy values 5 rows below the last data on that sheet
Dim Res As Variant, lookupval As Variant
Dim lookuprng As Range, c As Range
Dim LR As Long
'Below is the lookupval column of Actual Keys
LR = Sheets("Actual").Cells(Rows.Count, "A").End(xlUp).Row
Set lookuprng = Worksheets("Expected").Range("A3:A150000")
'Above is range of the lookup in the Expected tab
For Each c In Sheets("Actual").Range("A3:A" & LR)
lookupval = c.Value
Res = Application.Match(lookupval, lookuprng, 0)
'Now its looking for a match between Actual and Expected keys
'When there isn't a match it returns the lookupval aka actual extra key
If IsError(Res) Then
Sheets("Compare Result").Cells(Rows.Count, "D").End(xlUp).Offset(x).Value = c.Value
'Below is the label for extras
Sheets("Compare Result").Select
Range("A6").Select
Selection.End(xlDown).Select
ActiveCell.Offset(5, 0).Select
Selection = "Extra Actuals"
Selection.Interior.ColorIndex = 6
x = 1
'Now has cells that are being copied 1 row below last actual extra.
End If
Next c
Application.Calculation = xlCalc
Exit Sub
CalcBack:
Application.Calculation = xlCalc
End Sub