I'm getting a type mismatch error while comparing a range value to "" or vbNullString. i read many similar q+a posts that deal with this issue.
The data is all numbers or "".
Sub vegetableCounting()
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim ws1Range As Excel.range, ws2Range As Excel.range, ws3Range As Excel.range, ws2Loop As Excel.range
Dim ws1Row As Long, ws1Col As Long, ws2Row As Long, ws2Col As Long
'
Dim rowCounter As Long, colCounter As Long, rowsMendo As Long
Dim mendoSum As Double
'
Set ws1 = Sheets("shareSchedule")
Set ws2 = Sheets("shareDistribution")
Set ws3 = Sheets("vegCount")
'***not yet set to the full ranges***
Set ws1Range = ws1.range("E7:H11") 'shareSchedule
Set ws2Range = ws2.range("D7:BB17") 'shareDistribution
Set ws3Range = ws3.range("D7:BB11") 'vegetableCount
'***not yet set to the full ranges***
rowsMendo = 0
rowCounter = 0
colCounter = 0
mendoSum = 0
For ws1Row = 0 To ws1Range.Rows.count Step 1
For ws1Col = 0 To ws1Range.Columns.count Step 1
If ws1Range.Offset(ws1Row, ws1Col).value <> "" Then
For Each ws2Loop In ws2Range '11rows*51cols = 561
ws2Row = ws2Row + rowCounter + rowsMendo
ws2Col = ws2Col + colCounter
If ws2Range.Offset(ws2Row, ws2Col).value = "" Then
Exit For
Else
If ws1Range.Offset(ws1Row, ws1Col).Interior.ColorIndex = 24 And _
ws2Range.Offset(ws2Row, ws2Col).Interior.ColorIndex = 24 Then 'a MENDO match
If rowCounter < 3 Then
mendoSum = mendoSum + ws1Range.Offset(ws1Row, ws1Col).value * ws2Range.Offset(ws2Col, ws2Row)
rowCounter = rowCounter + 1
ElseIf rowCounter = 3 Then
colCounter = colCounter + 1
rowCounter = 0
ElseIf colCounter = ws2Range.Columns.count + 1 And _
ws2Range.Offset(ws2Row, 1).Interior.ColorIndex = 24 And _
ws2Range.Offset(ws2Row + 4, 1).Interior.ColorIndex = 24 Then
colCounter = 0
rowsMendo = rowsMendo + 3
ElseIf colCounter = ws2Range.Columns.count + 1 And _
ws2Range.Offset(ws2Row, 1).Interior.ColorIndex = xlNone And _
ws2Range.Offset(ws2Row + 4, 1).Interior.ColorIndex = xlNone Then
colCounter = 0
rowsMendo = rowsMendo + 1
End If
ws3Range.Offset(ws1Row, ws2Col) = ws1Range.Offset(ws1Row, ws1Col).value * ws2Range.Offset(ws2Row, ws2Col).value
End If
End If
Next
End If
Next ws1Col
Next ws1Row
'for ws2
'Offset(0, 0), Offset(1, 0), Offset(2, 0), then
'Offset(0, 1), Offset(1, 1), Offset(2, 1), then
'Offset(0, 2), Offset(1, 2), Offset(2, 2), then
'etc
End Sub
i get the error on
If ws1Range.Offset(ws1Row, ws1Col).value <> "" Then
and ill prob get it again on
If ws2Range.Offset(ws2Row, ws2Col).value = "" Then
any thoughts? here are some images of the worksheets im trying to pull from
You could try CStr to convert the value to a String. Format could also be used as it handles Null whereas CStr would produce an error.
So either:
If CStr(ws1Range.Offset(ws1Row, ws1Col).value) <> "" Then
or
If Format(ws1Range.Offset(ws1Row, ws1Col).value) <> "" Then
I don't usually use the Offset function, but you can access the cells in a specified range by directly specifiying the row and column like an array.
EG: ws2Range(ws2Row, ws2Col).value
You have to start in 1 for your iterations though, you'll get an error when you start at 0.
when looking at the offset of a range, you get the entire range area, offset by your offset values.
e.g.
set a=sheets(1).range("A1:F40")
debug.print a.offset(1,1).address
giveas a result of
$B$2:$G$41
notice this is (A+1,1+1:F+1,40+1) and not a single cell
there are 2 options:
set your range to a single cell, and use offset to look at the area around that cell
use the range you have now, and use cells(x,y) to look in that range
Related
I have two huge workbooks (old & new) of annual employee data and trying to compare. Each workbook has the same header and employees are in random order.
Here is what I'm trying to accomplish:
Use employee ID (in column D) as reference and compare if they’ve changed information, specially Physician (in column L).
Generate report highlight the different cell with added column (Change Information “Yes/No”) if there are changes or not.
Problem:
This code compare cell by cell only (took a lot of time) and not per employee id how could I insert here the looping of employee id? I am newbie in VBA. Any guidance on how I should go about this? Thanks.
Sub compare2Worksheets()
Dim ws1row As Long, ws2row As Long, ws1col As Integer, ws2col As Integer
Dim maxrow As Long, maxcol As Integer, colval1 As String, colval2 As String
Dim report As Workbook, difference As Long
Dim row As Long, col As Integer
Dim ws1 As Workbooks
Dim ws2 As Workbooks
Set report = Workbooks.Add
'range of Data1
Set ws1 = ThisWorkbook.Worksheets(“Data1”)
With ws1.UsedRange
ws1row = .Rows.Count
ws1col = .Columns.Count
End With
'range of Data2
Set ws2 = myworkbook.Worksheets(“Data2”)
With ws2.UsedRange
ws2row = .Rows.Count
ws2col = .Columns.Count
End With
maxrow = ws1row
maxcol = ws1col
If maxrow < ws2row Then maxrow = ws2row
If maxcol < ws2col Then maxcol = ws2col
'generate report
report.Worksheets(“Sheet1”).Activate
Cells.Clear
Range(“A1”) = “FirstName”
Range(“B1”) = “LastName”
Range(“C1”) = “DOB”
Range(“D1”) = “EmployeeID”
Range(“E1”) = “Address”
Range(“F1”) = “Emailadd”
Range(“G1”) = “Mobilenumber”
Range(“H1”) = “DeptID”
Range(“I1”) = “DeptName”
Range(“J1”) = “Position”
Range(“K1”) = “Status”
Range(“L1”) = “Physician”
Range(“M1”) = “Change InformationY / N”
erow = Data1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).row
'look for differences
difference = 0
For col = 1 To maxcol
For row = 1 To maxrow
colval1 = ws1.Cells(row, col)
colval2 = ws2.Cells(row, col)
If colval1 <> colval2 Then
difference = difference + 1
'not matched display and highlight
Cells(row, col) = colval1 & “ <> ” & colval2
Cells(row, col).Interior.Color = 255
Cells(row, col).Font.ColorIndex = 2
Cells(row, col).Font.Bold = True
'to update “Change InformationY / N”
Cells(row + 1, 13).Value = "Yes"
Else
Cells(row, col) = colval2
Cells(row + 1, 13).Value = "No"
End If
Next row
Next col
'saving report
If difference > 0 Then
Columns("A:B").ColumnWidth = 25
myfilename = InputBox("Enter Filename")
myfilename = myfilename & “.xlsx”
ActiveWorkbook.SaveAs Filename:=myfilename
End If
End Sub
I would do the following here:
First I would create an array for the EmployeeID and the rows I found them in both sheets.
For that I need to declare a RecordType (has to be defined at the beginning of the module, not in the procedure!)
I assume, that you have less than 1024 employees to handle, if more, simply use a higher value in the Dim-Statement.
I also assume, that the Employee-Id is a string, otherwise you have to use 'Long' or 'Integer' instead
Type EmpRowRec
EmpId as string
Row1 as Long
Row2 as Long
End Type
Dim EmpRowArr(1 to 1024) as EmpRowRec, EmpRowCnt as integer
Then I would go through both sheets and search for the row with the data for an employee:
Dim CurRow as long, CurEmpRow as integer,EmpRowOut as integer
…
EmpRowCnt=0
For CurRow = 2 to ws1Row
Colval1=ws1.cells(currow,4).value
EmpRowCnt=EmpRowCnt+1
EmpRowArr(EmpRowCnt).EmpId=colval1
EmpRowArr(EmpRowCnt).row1=CurRow
Next CurRow
For CurRow = 2 to ws2Row
Colval1=ws2.cells(currow,4).value
EmpRowOut=0
For CurEmpRow=1 to EmpRowCnt
If EmpRowArr(CurEmpRow).EmpId=ColVal1 then EmpRowOut=0:Exit For
Next CurEmpRow
If EmpRowOut=0 then ' Employee is only in sheet 2
EmpRowCnt=EmpRowCnt+1
EmpRowArr(EmpRowCnt).EmpId=colval1
EmpRowArr(EmpRowCnt).row2=CurRow
else
EmpRowArr(EmpRowOut).row2=CurRow
End If
Next CurRow
Now you can go through the array and create your report:
Currow =1 'You already copied the head values
For CurEmpRow=1 to EmpRowCnt
with EmpRowArr(CurEmpRow)
If (.row1>0) and (.row2>0) then 'your result will show only employees in both sheets
Currow=currow+1
For col=1 to maxcol
Colval1=ws1.cells(.row1,col).value
Colval2=ws1.cells(.row2,col).value
Report.cells(currow,col).value=colval1
If colval1<>colval2 then report.cells(currow,col).interior.color=rgb(255,200,200)
Next col
End if
End with
Next CurEmpRow
This method shall show you a generic way to solve such a problem (I have to deal very often with). For sure adaptions e.g. how to handle employees appearing only in one sheet, marking changes with low or high impact are needed, but here I can't help you since I don't know your exact requests.
Due to the fact, that I wrote this text only in word I could not test the fragments under VBA, so some small errors may occur. Please try to fix it.
This is the code with your logic:
Type EmpRowRec
EmpId As String
Row1 As Long
Row2 As Long
End Type
Sub compare2Worksheets()
Dim ws1row As Long, ws2row As Long, ws1col As Integer, ws2col As Integer
Dim maxrow As Long, maxcol As Integer, colval1 As String, colval2 As String
Dim report As Workbook, difference As Long
Dim row As Long, col As Integer
Dim CurRow As Long, CurEmpRow As Integer, EmpRowOut As Integer
Dim wbkA As Workbook, wbkB As Workbook
Dim EmpRowArr(1 To 1024) As EmpRowRec, EmpRowCnt As Integer
'get worksheets from the workbooks
Set wbkA = Workbooks("Data1")
Set ws1 = wbkA.Worksheets("Data1")
'range of Data1
With ws1.UsedRange
ws1row = .Rows.Count
ws1col = .Columns.Count
End With
Set wbkB = Workbooks("Data2")
Set ws2 = wbkB.Worksheets("Data2")
'range of Data2
With ws2.UsedRange
ws2row = .Rows.Count
ws2col = .Columns.Count
End With
maxrow = ws1row
maxcol = ws1col
If maxrow < ws2row Then maxrow = ws2row
If maxcol < ws2col Then maxcol = ws2col
'generate report workbook
Set report = Workbooks.Add
report.Worksheets("Sheet1").Activate
Cells.Clear
Range(“A1”) = “FirstName”
Range(“B1”) = “LastName”
Range(“C1”) = “DOB”
Range(“D1”) = “EmployeeID”
Range(“E1”) = “Address”
Range(“F1”) = “Emailadd”
Range(“G1”) = “Mobilenumber”
Range(“H1”) = “DeptID”
Range(“I1”) = “DeptName”
Range(“J1”) = “Position”
Range(“K1”) = “Status”
Range(“L1”) = “Physician”
Range(“M1”) = “Change InformationY / N”
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).row
'go through both sheets and search for the row with the data for an employee
EmpRowCnt = 0
For CurRow = 2 To maxrow 'ws1row
colval1 = ws1.Cells(CurRow, 4).Value
EmpRowCnt = EmpRowCnt + 1
EmpRowArr(EmpRowCnt).EmpId = colval1
EmpRowArr(EmpRowCnt).Row1 = CurRow
Next CurRow
For CurRow = 2 To maxrow 'ws2row
colval1 = ws2.Cells(CurRow, 4).Value
EmpRowOut = 0
For CurEmpRow = 1 To EmpRowCnt
If EmpRowArr(CurEmpRow).EmpId = colval1 Then EmpRowOut = 0: Exit For
Next CurEmpRow
If EmpRowOut = 0 Then ' Employee is only in sheet 2
EmpRowCnt = EmpRowCnt + 1
EmpRowArr(EmpRowCnt).EmpId = colval1
EmpRowArr(EmpRowCnt).Row2 = CurRow
Else
EmpRowArr(EmpRowOut).Row2 = CurRow
End If
Next CurRow
'go through the array and create your report
CurRow = 1 'You already copied the head values
For CurEmpRow = 1 To EmpRowCnt
With EmpRowArr(CurEmpRow)
If (.Row1 > 0) And (.Row2 > 0) Then 'your result will show only employees in both sheets
CurRow = CurRow + 1
For col = 1 To maxcol
colval1 = ws1.Cells(.Row1, col).Value
colval2 = ws1.Cells(.Row2, col).Value
report.Cells(CurRow, col).Value = colval1
If colval1 <> colval2 Then report.Cells(CurRow, col).Interior.Color = RGB(255, 200, 200)
Next col
End If
End With
Next CurEmpRow
If CurRow > 0 Then
Columns("A:Y").ColumnWidth = 25
myfilename = InputBox("Enter Filename")
myfilename = myfilename & “.xlsx”
ActiveWorkbook.SaveAs Filename:=myfilename
End If
End Sub
Use a Dictionary as a lookup table for the row number of each ID on the old data sheet. Then scan down the new sheet comparing rows with the same ID. IDs that appear on the new sheet but not the old are tagged "added". Those on the old sheet but not the new are tagged "deleted".
Option Explicit
Sub compare2Worksheets()
' config
Const COL_ID = "D"
Const COLS = 12 ' header col A to L
Dim wb1 As Workbook, wb2 As Workbook, wbRep As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet, wsRep As Worksheet
Dim LastRow As Long, c As Long, i As Long, r As Long, n As Long
Dim bDiff As Boolean, t0 As Single
t0 = Timer
Dim dict As Object, key As String
Set dict = CreateObject("Scripting.Dictionary")
'range of Data1
Set wb1 = ThisWorkbook
Set wb2 = ThisWorkbook ' or other
Set ws1 = wb1.Sheets("Data1") ' old data
Set ws2 = wb2.Sheets("Data2") ' new data
' build lookup from data1
With ws1
LastRow = .Cells(.Rows.Count, COL_ID).End(xlUp).row
For i = 2 To LastRow
key = Trim(.Cells(i, COL_ID))
If dict.exists(key) Then
MsgBox "Duplicate ID " & key, vbCritical, .Name & " Row " & i
Exit Sub
ElseIf Len(key) > 0 Then
dict.Add key, i
End If
Next
End With
' format report sheet
Set wbRep = Workbooks.Add(1)
Set wsRep = wbRep.Sheets(1)
wsRep.Name = "Created " & Format(Now, "YYYY-MM-DD HHMMSS")
ws1.Range("A1").Resize(, COLS).Copy wsRep.Range("A1")
wsRep.Cells(1, COLS + 1) = "Change InformationY / N"
' copare data2 new data to data1 old data
' copy diff to report
Application.ScreenUpdating = False
With ws2
LastRow = .Cells(.Rows.Count, COL_ID).End(xlUp).row
For i = 2 To LastRow
key = Trim(.Cells(i, COL_ID))
wsRep.Cells(i, COL_ID) = key
If dict.exists(key) Then
r = dict(key)
dict.Remove key ' remove
' check columns in row
bDiff = False
For c = 1 To COLS
If .Cells(i, c) <> ws1.Cells(r, c) Then
With wsRep.Cells(i, c)
.Value = ws2.Cells(i, c) & "<>" & ws1.Cells(r, c)
.Interior.Color = 255
.Font.ColorIndex = 2
.Font.Bold = True
End With
bDiff = True
End If
Next
If bDiff Then
wsRep.Cells(i, COLS + 1) = "Yes"
n = n + 1
Else
wsRep.Cells(i, COLS + 1) = "No"
End If
Else
' copy all
.Cells(i, 1).Resize(, COLS).Copy wsRep.Cells(i, 1)
wsRep.Cells(i, COLS + 1) = "Added"
n = n + 1
End If
Next
End With
' keys remaining
Dim k
With ws1
For Each k In dict.keys
r = dict(k)
.Cells(r, 1).Resize(, COLS).Copy wsRep.Cells(i, 1)
wsRep.Cells(i, COL_ID) = k
wsRep.Cells(i, COLS + 1) = "Deleted"
i = i + 1
n = n + 1
Next
End With
Application.ScreenUpdating = True
Dim s As String, yn
wsRep.Columns("A:M").AutoFit
yn = MsgBox(n & " lines differ, save report Y/N ?", vbYesNo, _
Format(Timer - t0, "0.0 secs"))
If yn = vbYes Then
s = InputBox("Enter Filename")
wbRep.SaveAs Filename:=s & ".xlsx"
End If
wbRep.Close False
End Sub
Sorry, I have overseen, that 'Report' is a workbook, not a sheet. PLease replace 'Report.Cells()' with 'Report.Worksheets("Sheet1").Cells()'
I'm having issues with a loop performing multiple if-conditionals. What im doing is
1. Define ranges and cells for "what to look for and where to look from".
2. Issue part: My If should be three-leveled.
- If x is true, do things, else if2
- If2 is true, do things, else if3
- if3 is true, do things
Loop next x
For some reason it goes fine for a couple of times but then it gives me Object variable or With block variable not set. How do i fix this..?
The error is on line:
If Not cl Is Nothing And Worksheets("Sheet1").Cells(x + 1, 7) = cl.Offset(0, -4) Then
Sub Question()
Dim lr1 As Long
Dim lr2 As Long
Dim lr3 As Long
Dim lr4 As Long
Dim x As Long, y As Long, n As Integer
Dim arr As Variant, arr2 As Variant
Dim rng As Range, cl As Range
Dim rng2 As Range, c2 As Range
n = 20 'Start row of Sheet1
m = 20 'Start row of Sheet2
o = 20 'Start row of Sheet3
'Fill the array for a loop in memory
With Blad6
lr1 = Worksheets("Sheet4").Cells(.Rows.Count, 1).End(xlUp).Row
arr = Worksheets("Sheet4").Range("A2:A" & lr1 + 1)
lr3 = Worksheets("Sheet4").Cells(.Rows.Count, 1).End(xlUp).Row
arr2 = Worksheets("Sheet4").Range("A2:A" & lr1 + 1)
End With
'Get the range to look in
With Sheet1
lr2 = Worksheets("Sheet5").Cells(.Rows.Count, 2).End(xlUp).Row
Set rng = Worksheets("Sheet5").Range("H2:H" & lr2)
End With
With Blad6
'Loop over the array and perform the search
For x = 1 To UBound(arr)
Set cl = rng.Find(arr(x, 1), LookIn:=xlValues)
If Not cl Is Nothing And Worksheets("Sheet1").Cells(x + 1, 7) = cl.Offset(0, -4) Then
'Things happen here
n = n + 1
Else
If Not cl Is Nothing And Worksheets("").Cells(x + 1, 7) <> cl.Offset(0, -4) And cl.Offset(0, -4) <> 0 And cl.Offset(0, -5) > Worksheets("").Cells(x + 1, 3) Then
'Things happen here
m = m + 1
Else
If cl Is Nothing Then
'Things happen here
o = o + 1
End If
End If
End If
Next
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
End Sub
VBA evaluates both sides of the AND statement, so if cl is nothing, it still tries to use it on the second part (giving you an error)...
You need to nest 2 If's instead like this
If Not cl Is Nothing
If Worksheets("Sheet1").Cells(x + 1, 7) = cl.Offset(0, -4) Then
' do stuff here if cl is valid and offset condition is met
Else
' do stuff if cl is valid but does not meet the offset condition
End If
Else
' do something when cl is nothing
' could be the same thing as in above Else
' assuming cl is not involved in the operation
End If
If you were using VB.NET then you could use AndAlso instead and structure it more like you have it, but you aren't, so you can't.
I'm currently working on a project which needs to build graph regarding to a table of analyses to check if the products work with time.
The user starts to choose which products he want to check and the code create a table regarding that.
The two main values are the date and the result which need to be on the graph and the third one is the batch number which needs to be the name of each chart series.
After that the code creates a 2D array with the table.
For Each elementReo In Range("tabReorganize[Date]")
ReDim Preserve tabReo(2, r)
tabReo(0, r) = elementReo
tabReo(1, r) = 0 & elementReo.Offset(0, 1)
tabReo(2, r) = elementReo.Offset(0, 2)
r = r + 1
Next elementReo
And after that I want to create the graph regarding to the number of different batch number that I have.
'This part create the Chart and set the title
Set ChartObj = ActiveSheet.ChartObjects.Add(Left:=2979.75, Width:=550, Top:=358.5, Height:=325)
ChartObj.Chart.ChartType = xlLine
ChartObj.Chart.SetElement (msoElementChartTitleAboveChart)
ChartObj.Chart.ChartTitle.Text = "Humidite"
Dim tabNBN() As String
Dim NBN As Integer
Dim checkNBN As Boolean
ReDim tabNBN(NBN)
Dim SeriesI As Integer
NBN = 0
SeriesI = 0
'Add value in tabNBN regarding to the number of different batch number
For r2 = 0 To r - 1 Step 1
checkNBN = False
For Each elementNBN In tabNBN
If elementNBN = tabReo(1, r2) Then
checkNBN = True
End If
Next elementNBN
If checkNBN = False Then
ReDim Preserve tabNBN(NBN)
tabNBN(NBN) = tabReo(1, r2)
NBN = NBN + 1
End If
Next r2
So I need something to add the series regarding of the number of different batch number and insert the value and the date there.
I'm a beginner with charts in VBA.
if my understanding of the objective is correct then congratulation for a good & challenging question. Assuming the objective is to create a single chart with multiple series representing each batch listed in the range. If assumed result is like the following
then may try the test code (obviously after modifying the range, sheet etc to requirement). The code used Dictionary object, so please add Tools-> Reference to "Microsoft Scripting Runtime". Though I am not fully satisfied with the code regarding some multiple looping etc (degrading the performance) but would work OK with normal data assuming 100/200 rows. I invite experts response for more efficient code in this regard
Option Explicit
Sub test3()
Dim Cht As Chart, ChartObj As ChartObject
Set ChartObj = ActiveSheet.ChartObjects.Add(Left:=10, Width:=550, Top:=10, Height:=325)
'Set ChartObj = ActiveSheet.ChartObjects("Chart 4")
Set Cht = ChartObj.Chart
Cht.ChartType = xlLine
Cht.HasTitle = True
Cht.ChartTitle.Text = "Humidite"
Dim Rw As Long, Dic As Dictionary, DataArr As Variant, OutArr() As Variant, BatchArr() As Variant, DateArr As Variant
Dim Rng As Range, SeriesNo As Long, Dmax As Date, Dmin As Date, dt As Date
Dim X As Long, i As Long, Xbatch As Variant, Batch As Variant
Dim Cnt As Long, Xval As Variant, PrvDt As Date, C As Range, DayCnt As Long
Dim firstAddress As String
Set Dic = CreateObject("Scripting.dictionary")
Set Rng = ThisWorkbook.ActiveSheet.Range("A2:A100") 'Modify to requireMent
DataArr = ThisWorkbook.ActiveSheet.Range("A2:C100") 'Modify to requireMent
SeriesNo = 0
'Create dictionary reference to unique Batch name from the list
For Rw = 1 To UBound(DataArr, 1)
Batch = DataArr(Rw, 2)
If Dic.Exists(Batch) = False Then
SeriesNo = SeriesNo + 1
Dic.Add Batch, SeriesNo
End If
Next
Dmax = Application.WorksheetFunction.Max(Range(Rng(1, 1), Rng(Rng.Rows.Count, 1)))
Dmin = Application.WorksheetFunction.Min(Range(Rng(1, 1), Rng(Rng.Rows.Count, 1)))
DayCnt = Dmax - Dmin + 1
ReDim BatchArr(1 To DayCnt)
ReDim DateArr(1 To DayCnt)
ReDim OutArr(1 To SeriesNo, 1 To DayCnt)
'Populate DateArr for dates
For X = 1 To DayCnt
DateArr(X) = Dmin + X - 1
Next
'Populate OutArr(Series,DayCnt) with existing Values, Non existing values are kept empty
For X = 1 To DayCnt
dt = DateArr(X)
With Rng
Set C = .Find(dt)
If Not C Is Nothing Then
firstAddress = C.Address
Do
OutArr(Dic(C.Offset(0, 1).Value), X) = C.Offset(0, 2).Value
'Debug.Print C.Value, C.Offset(0, 1).Value, C.Offset(0, 2).Value
Set C = .FindNext(C)
Loop While Not C Is Nothing And C.Address <> firstAddress
End If
End With
Next
With Cht
'delete If any automatically added series
For i = Cht.SeriesCollection.Count To 1 Step -1
.SeriesCollection(i).Delete
Next
'Create Series and Set Values & Xvalues from OutArr
Dim Srs As Series
For X = 1 To SeriesNo
Batch = Dic.Keys(X - 1)
For Cnt = 1 To DayCnt
BatchArr(Cnt) = OutArr(Dic(Batch), Cnt)
'If IsEmpty(BatchArr(Cnt)) = False Then Debug.Print X, Cnt, BatchArr(Cnt), DateArr(Cnt)
Next
Cht.SeriesCollection.NewSeries
Set Srs = Cht.SeriesCollection(X)
With Srs
.Values = BatchArr
.XValues = DateArr
.Name = Dic.Keys(X - 1)
End With
Next
Dim Cat As Axis
Set Cat = Cht.Axes(xlCategory)
Cat.TickLabels.NumberFormat = "dd/mm/yy"
End With
End Sub
Please comment if it suits your need
This code should create a table regarding to another table (the one with all different batch numbers and values) and the user selection and after build the chart with it.
I can send you the full file by mail if needed.
Thanks in advance.
Best regards
colin
Private Sub BtnGraph2_Click()
Dim tabBNumber() As String
Dim tabHumidite() As Double
Dim tabDate() As String
Dim tabReo() As String
Dim y As Integer
Dim h As Integer
Dim d As Integer
Dim a As Integer
Dim w As Integer
Dim w2 As Integer
Dim r As Integer
h = 0
y = 0
d = 0
w = 1
w2 = 1
r = 0
ReDim tabHumidite(h)
ReDim tabBNumber(y)
ReDim tabDate(d)
Range("tabReorganize[#data]") = ""
ListObjects("tabReorganize").Resize Range(Range("tabReorganize[#headers]").Address, Range("tabReorganize[#headers]").Offset(1).Address)
For i6 = ListBox1.ListCount - 1 To 0 Step -1
If ListBox1.Selected(i6) = True Then
ReDim Preserve tabBNumber(y)
tabBNumber(y) = ListBox1.List(i6)
y = y + 1
End If
Next i6
For Each delement In tabBNumber
For Each delement2 In Range("tabGraph[Date]")
If "0" & delement2.Offset(0, 2) = delement Or delement2.Offset(0, 2) = delement Then
ReDim Preserve tabDate(d)
tabDate(d) = delement2
d = d + 1
End If
Next delement2
Next delement
For Each Oelement In tabDate
Range("tabReorganize[Date]").Cells(w) = Format(Oelement, "mm/dd/yyyy")
w = w + 1
Next Oelement
If BtnHumidite = True Then
For Each element In tabBNumber
h = 0
a = 0
ReDim tabHumidite(h)
For Each Gelement In Range("tabGraph[Humidite]")
If "0" & Gelement.Offset(0, -1) = element Or Gelement.Offset(0, -1) = element Then
ReDim Preserve tabHumidite(h)
tabHumidite(h) = Gelement
h = h + 1
End If
Next Gelement
For Each O2element In tabHumidite
Range("tabReorganize[Humidite]").Cells(w2) = Format(O2element, "###0.00")
Range("tabReorganize[Batch Number]").Cells(w2) = Format(element, "00000000")
w2 = w2 + 1
Next O2element
Next element
End If
Range("tabReorganize").Sort Key1:=Range("tabReorganize[[#All],[Date]]"), Order1:=xlAscending, Header:=xlYes
For Each elementReo In Range("tabReorganize[Date]")
ReDim Preserve tabReo(2, r)
tabReo(0, r) = elementReo
tabReo(1, r) = 0 & elementReo.Offset(0, 1)
tabReo(2, r) = elementReo.Offset(0, 2)
r = r + 1
Next elementReo
'''' Chart part
Dim Cht As Chart, ChartObj As ChartObject
Set ChartObj = ActiveSheet.ChartObjects.Add(Left:=2979.75, Width:=550, Top:=358.5, Height:=325)
Set Cht = ChartObj.Chart
Cht.ChartType = xlLine
Cht.HasTitle = True
Cht.ChartTitle.Text = "Humidite"
Dim Rw As Long, Dic As Dictionary, DataArr As Variant, OutArr() As Variant, BatchArr() As Variant, DateArr As Variant
Dim Rng As Range, SeriesNo As Long, Dmax As Date, Dmin As Date, dt As Date
Dim X As Long, i As Long, Xbatch As Variant, Batch As Variant
Dim Cnt As Long, Xval As Variant, PrvDt As Date, C As Range, DayCnt As Long
Dim firstAddress As String
Set Dic = CreateObject("Scripting.dictionary")
Set Rng = ThisWorkbook.ActiveSheet.Range("AP13:AP42") 'Modify to requireMent
'Set Rng = ThisWorkbook.ActiveSheet.Range("tabReorganize[Date]")
DataArr = ThisWorkbook.ActiveSheet.Range("AP13:AR42") 'Modify to requireMent
'DataArr = ThisWorkbook.ActiveSheet.Range("tabReorganize[#data]")
SeriesNo = 0
'Create dictionary reference to unique Batch name from the list
For Rw = 1 To UBound(DataArr, 1)
Batch = DataArr(Rw, 2)
If Dic.Exists(Batch) = False Then
SeriesNo = SeriesNo + 1
Dic.Add Batch, SeriesNo
End If
Next
Dmax = Application.WorksheetFunction.max(Range(Rng(1, 1), Rng(Rng.Rows.Count, 1)))
Dmin = Application.WorksheetFunction.Min(Range(Rng(1, 1), Rng(Rng.Rows.Count, 1)))
DayCnt = Dmax - Dmin + 1
ReDim BatchArr(1 To DayCnt)
ReDim DateArr(1 To DayCnt)
ReDim OutArr(1 To SeriesNo, 1 To DayCnt)
'Populate DateArr for dates
For X = 1 To DayCnt
DateArr(X) = Dmin + X - 1
Next
'Populate OutArr(Series,DayCnt) with existing Values, Non existing values are kept empty
For X = 1 To DayCnt
dt = DateArr(X)
With Rng
Set C = .Find(dt)
If Not C Is Nothing Then
firstAddress = C.Address
Do
OutArr(Dic(C.Offset(0, 1).Value), X) = C.Offset(0, 2).Value
'Debug.Print C.Value, C.Offset(0, 1).Value, C.Offset(0, 2).Value
Set C = .FindNext(C)
Loop While Not C Is Nothing And C.Address <> firstAddress
End If
End With
Next
With Cht
'delete If any automatically added series
For i = Cht.SeriesCollection.Count To 1 Step -1
.SeriesCollection(i).Delete
Next
'Create Series and Set Values & Xvalues from OutArr
Dim Srs As Series
For X = 1 To SeriesNo
Batch = Dic.Keys(X - 1)
For Cnt = 1 To DayCnt
BatchArr(Cnt) = OutArr(Dic(Batch), Cnt)
'If IsEmpty(BatchArr(Cnt)) = False Then Debug.Print X, Cnt, BatchArr(Cnt), DateArr(Cnt)
Next
Cht.SeriesCollection.NewSeries
Set Srs = Cht.SeriesCollection(X)
With Srs
.Values = BatchArr
.XValues = DateArr
.Name = Dic.Keys(X - 1)
End With
Next
Dim Cat As Axis
Set Cat = Cht.Axes(xlCategory)
Cat.TickLabels.NumberFormat = "mm/dd/yy"
End With
I have the following code:
Sub combinations()
Range("G2:G" & Range("G2").End(xlDown).Row).ClearContents
Range("H2:G" & Range("H2").End(xlDown).Row).ClearContents
Range("I2:G" & Range("I2").End(xlDown).Row).ClearContents
Range("J2:G" & Range("J2").End(xlDown).Row).ClearContents
Dim c1() As Variant
Dim c2() As Variant
Dim c3() As Variant
Dim c4() As Variant
Dim out() As Variant
Dim j As Long, k As Long, l As Long, m As Long, n As Long
Dim col1 As Range
Dim col2 As Range
Dim col3 As Range
Dim col4 As Range
Dim out1 As Range
Set col1 = Range("A2", Range("A2").End(xlDown))
Set col2 = Range("B2", Range("B2").End(xlDown))
Set col3 = Range("C2", Range("C2").End(xlDown))
Set col4 = Range("D2", Range("D2").End(xlDown))
c1 = col1
c2 = col2
c3 = col3
c4 = col4
Set out1 = Range("G2", Range("K2").Offset(UBound(c1) * UBound(c2) * UBound(c3) * UBound(c4)))
out = out1
j = 1
k = 1
l = 1
m = 1
n = 1
Do While j <= UBound(c1)
Do While k <= UBound(c2)
Do While l <= UBound(c3)
Do While m <= UBound(c4)
out(n, 1) = c1(j, 1)
out(n, 2) = c2(k, 1)
out(n, 3) = c3(l, 1)
out(n, 4) = c4(m, 1)
n = n + 1
m = m + 1
Loop
m = 1
l = l + 1
Loop
l = 1
k = k + 1
Loop
k = 1
j = j + 1
Loop
out1.Value = out
End Sub
It creates all possible combination for values you put in A:A through D:D.
Example of a working table:
Header1 Header2 Header3 Header4
A1 B1 C1 D1
A2 B2 C2 D2
A3 B3 C3 D3
The only time it does not work is when one of the columns only has 1 value.
Example of a not working table:
Header1 Header2 Header3 Header4
A1 B1 C1 D1
B2 C2 D2
B3 C3 D3
I get a
Run-time error '1004;
Is there a way to fix this so that it would work for columns with 1 value as well?
This should work for you. Please note that it will work for any number of columns, not just 4, and that it will also work if any of the columns don't have full population (though each column must have at least one populated cell).
Sub tgr()
Dim ws As Worksheet
Dim rDest As Range
Dim aHeaders() As Variant
Dim aTemp() As Variant
Dim aData() As Variant
Dim aResults() As Variant
Dim vTemp As Variant
Dim ixData As Long
Dim ixResult As Long
Dim ixRow As Long
Dim ixCol As Long
Dim lMaxRows As Long
Dim lResultsBlock As Long
Dim lOverflowResults As Long
Dim bPopulated As Boolean
'Adjust these as necessary
Set ws = ActiveWorkbook.Worksheets(1) 'The worksheet that contains the table of values
Set rDest = ws.Range("G2") 'The worksheet and cell where results should be output to
lResultsBlock = 100000 'The number of rows the results array can contain before having to output results and then continuing
'Get table of values that will be used to create combinations, assume table starts in A1 and has headers
With ws.Range("A1").CurrentRegion
If .Rows.Count = 1 Then Exit Sub 'No data
If .Cells.Count = 2 Then
ReDim aHeaders(1 To 1, 1 To 1)
aHeaders(1, 1) = .Cells(1).Value
ReDim aData(1 To 1, 1 To 1)
aData(1, 1) = .Cells(2).Value
Else
aHeaders = .Resize(1).Value
aData = .Offset(1).Resize(.Rows.Count - 1).Value
End If
lMaxRows = UBound(aData, 1) ^ UBound(aData, 2)
ReDim aResults(1 To lResultsBlock, 1 To UBound(aData, 2))
lOverflowResults = 0
End With
'Clear previous results
ClearResults rDest
'Iterate over the table of values and create every possible combination
For ixRow = 1 To lMaxRows
'Prevent Excel from looking frozen, show a % percent complete
If (ixRow - 1) Mod 10000 = 0 Then
DoEvents
Application.StatusBar = "Processing: " & Format(ixRow / lMaxRows, "0.00%") & " completed..."
End If
'Check if this combination has any empty/blank values
bPopulated = True
ReDim aTemp(1 To UBound(aResults, 2))
For ixCol = 1 To UBound(aResults, 2)
ixData = Int(((ixRow - 1) Mod (UBound(aData, 1) ^ (UBound(aData, 2) - (ixCol - 1)))) / (UBound(aData, 1) ^ (UBound(aData, 2) - ixCol))) + 1
vTemp = aData(ixData, ixCol)
If Len(vTemp) > 0 Then
aTemp(ixCol) = vTemp
Else
'Empty/blank found, skip this combination
bPopulated = False
Exit For
End If
Next ixCol
If bPopulated Then
'No empties/blanks found in this combination, add it to results
ixResult = ixResult + 1
For ixCol = 1 To UBound(aResults, 2)
aResults(ixResult, ixCol) = aTemp(ixCol)
Next ixCol
Erase aTemp
'Output results if the results array is full
If ixResult = UBound(aResults, 1) Then OutputResults ws, rDest, aResults, ixResult, lOverflowResults, aHeaders
End If
Next ixRow
'Output results if results array is at least partially populated
If ixResult > 0 Then OutputResults ws, rDest, aResults, ixResult, lOverflowResults, aHeaders
Application.StatusBar = vbNullString
End Sub
'This will clear any previous results
Sub ClearResults(ByVal arg_rDest As Range)
Dim ws As Worksheet
arg_rDest.CurrentRegion.ClearContents
Application.DisplayAlerts = False
For Each ws In arg_rDest.Worksheet.Parent.Worksheets
If ws.Name Like "Overflow Results (*)" Then ws.Delete
Next ws
Application.DisplayAlerts = True
End Sub
'This will output the current results array to the appropriate destination, accounting for if a new sheet needs to be created and whether headers need to be provided
Sub OutputResults(ByRef arg_wsDest As Worksheet, _
ByVal arg_rDest As Range, _
ByRef arg_aResults As Variant, _
ByRef arg_ixResult As Long, _
ByRef arg_lOverflowResults As Long, _
Optional ByVal arg_aHeaders As Variant)
Dim rDest As Range
Dim lHeaderRow As Long
Dim lRowCount As Long
Dim lColCount As Long
'Check if this is the first time results are being output
If arg_wsDest.Cells(arg_wsDest.Rows.Count, arg_rDest.Column).End(xlUp).Row <= arg_rDest.Row Then
'This is the first time results are being output
arg_lOverflowResults = 0
'Check if headers need to be placed
If IsArray(arg_aHeaders) Then
If arg_rDest.Row = 1 Then lHeaderRow = 1 Else lHeaderRow = arg_rDest.Row - 1
With arg_wsDest.Cells(lHeaderRow, arg_rDest.Column).Resize(, UBound(arg_aHeaders, 2))
.Value = arg_aHeaders
.Font.Bold = True
End With
Set rDest = arg_wsDest.Cells(lHeaderRow + 1, arg_rDest.Column)
Else
Set rDest = arg_rDest
End If
End If
'These are used to create a new, empty results array after results are output
lRowCount = UBound(arg_aResults, 1)
lColCount = UBound(arg_aResults, 2)
'Check if there is room left in the current destination worksheet to contain all of the results
If arg_wsDest.Cells(arg_wsDest.Rows.Count, arg_rDest.Column).End(xlUp).Row + 1 + arg_ixResult > arg_wsDest.Rows.Count Then
'Not enough room found, create a new sheet to continue outputting results on and apply headers if necessary
arg_lOverflowResults = arg_lOverflowResults + 1
Set arg_wsDest = arg_wsDest.Parent.Worksheets.Add(AFter:=arg_wsDest)
arg_wsDest.Name = "Overflow Results (" & arg_lOverflowResults & ")"
If IsArray(arg_aHeaders) Then
With arg_wsDest.Cells(1, arg_rDest.Column).Resize(, UBound(arg_aHeaders, 2))
.Value = arg_aHeaders
.Font.Bold = True
End With
Set rDest = arg_wsDest.Cells(2, arg_rDest.Column)
Else
Set rDest = arg_wsDest.Cells(1, arg_rDest.Column)
End If
Else
'Enough room found, set destination for where results should begin
If rDest Is Nothing Then Set rDest = arg_wsDest.Cells(arg_wsDest.Rows.Count, arg_rDest.Column).End(xlUp).Offset(1)
End If
'Output results
rDest.Resize(arg_ixResult, UBound(arg_aResults, 2)).Value = arg_aResults
'Clear the existing results array and create a new, empty results array
Erase arg_aResults
ReDim arg_aResults(1 To lRowCount, 1 To lColCount)
arg_ixResult = 0
End Sub
I have written a code to compare two worksheets WS1 and Ws2. The code reads the primary key of each row from ws1 and finds the corresponding row with the same primary key in ws2 then all the other column attributes are matched between the two worksheets and reported accordingly.
The code is :
Sub DataComparator(ws1 As Worksheet, ws2 As Worksheet)
Dim ws1row As Long, ws2row As Long, ws1col As Integer, ws2col As Integer
Dim maxrow As Long, maxcol As Integer, colval1 As String, colval2 As String
Dim difference As Long, reportrow As Long, reportcol As Long, flag As Boolean
Dim row As Long, col As Long, pki As Long, pk As String, counter As Long
Dim PctDone As Single, cell1 As String, cell2 As String, bfailed As Boolean
TestDataComparator.FrameProgress.Visible = True
TestDataComparator.LabelProgress.Visible = True
'UserForm1.Visible = True
'Application.ScreenUpdating = False
DoEvents
With ws1.UsedRange
ws1row = .Rows.Count
ws1col = .Columns.Count
End With
With ws2.UsedRange
ws2row = .Rows.Count
ws2col = .Columns.Count
End With
maxrow = ws1row
maxcol = ws1col
pk = UCase(TestDataComparator.TextBox1.Value)
For col = 1 To maxcol
If pk = UCase(ws1.Cells(1, col).Formula) Then
pki = col
End If
Next col
If maxrow < ws2row Then maxrow = ws2row
If maxcol < ws2col Then maxcol = ws2col
difference = 0
reportrow = 0
For row = 2 To maxrow
keyval = ws1.Cells(row, 1).Formula
flag = False
bfailed = False
'reportcol = 1
For col = 2 To maxcol
'If col = pki Then
'Exit For
'End If
counter = counter + 1
cell1 = ""
cell2 = ""
cell1 = ws1.Cells(row, col).Formula
On Error Resume Next
'Set Rng = Range("A2:" & Cells(ws2row, "A").Address)
cell2 = Application.WorksheetFunction.VLookup(keyval, ws2.UsedRange, col, False)
If Err.Number <> 0 Then bfailed = True
On Error GoTo 0
If bfailed = True Then
Exit For
End If
If cell1 <> cell2 Then
flag = True
'difference = difference + 1
diffcolname = ws1.Cells(1, col)
ws1.Cells(row, col).Interior.Color = RGB(255, 255, 0)
ws1.Cells(1, col).Interior.Color = RGB(255, 0, 0)
ws1.Cells(row, col).Font.Bold = True
ws1.Cells(1, pki).Interior.Color = RGB(0, 255, 0)
ws1.Cells(row, pki).Interior.Color = RGB(255, 255, 0)
ws1.Cells(row, pki).Font.Color = RGB(255, 0, 0)
ws1.Cells(row, pki).Font.Bold = True
End If
Next col
If flag = True Then
reportrow = reportrow + 1
End If
PctDone = counter / (maxrow * maxcol)
TestDataComparator.FrameProgress.Caption = "Progress..." & Format(PctDone, "0%")
TestDataComparator.LabelProgress.Width = PctDone * (TestDataComparator.FrameProgress.Width - 10)
DoEvents
Next row
TestDataComparator.Totalcount.Value = row - 2
TestDataComparator.mismatchCount.Value = reportrow
TestDataComparator.mismatchCount.Font = Bold
difference = 0
For col = 1 To maxcol
If ws1.Cells(1, col).Interior.Color = RGB(255, 0, 0) Then
difference = difference + 1
TestDataComparator.AttributeNameList.AddItem (ws1.Cells(1, col))
End If
Next col
TestDataComparator.FrameProgress.Visible = False
TestDataComparator.LabelProgress.Visible = False
'TestDataComparator.PleaseWait.Visible = False
MsgBox difference & " columns contain different data! ", vbInformation, "Comparing Two Worksheets"
Application.ScreenUpdating = True
End Sub
I want the vlookup function to search for the match only in the entire column of WS2 which has the primary key (index pki) rather than ws2.UsedRange. Please provide suggestions. Is there any option which will perform better than vlookup? The use of ws2.UsedRange is making it difficult to search in large datasets that is why I want to reduce search space. My dataset has above 40K rows and 155 columns in excel. Also suggest me a formula for calculating the progress in the progress bar if you think it is not appropriate.
Sample data from OP's comment:
Name Height Weight
Jane 5'6'' 78
Mike 5'4'' 89
Monica 5'2'' 56
I think using a Dictionary (aka Hashtable in other languages) can make it faster. You will need to reference the Microsoft Scripting Runtime library.
You need to read ws2 key values with their row numbers into the Dictionary in one loop before you start going through ws1 row by row. Then in your loop you just look up the value in your dictionary to get its row number on ws2. Something like this:
Dim ws2keys As Dictionary
Set ws2keys = New Dictionary
' assuming you have a header row
For row = 2 To ws2.UsedRange.Rows.Count
keyValue = ws1.Cells(row, 1).Value
If keyValue <> "" Then ws2keys.Add(keyValue, row)
Next
' your dictionary is ready
Then in your loop, instead of using VLookup when going row by row on ws1:
ws2RowIndex = ws2keys.Item(ws1KeyValueYouAreLookingFor)
(The code might not be perfect, I do not have anything Microsoft related on this machine to check the syntax, sorry.)
I've reduced your VLOOKUP for every column to a single MATCH to verify that it exists and one MATCH to set the WS2 row where the match occurs. Everything else is done with direct addressing.
Sub DataComparator(ws1 As Worksheet, ws2 As Worksheet)
Dim ws1row As Long, ws2row As Long, ws1col As Long, ws2col As Long
Dim maxrow As Long, maxcol As Long, colval1 As String, colval2 As String
Dim difference As Long, reportrow As Long, reportcol As Long, flag As Boolean
Dim rw As Long, cl As Long, pki As Long, pk As String, counter As Long
Dim cell1 As String, cell2 As String, bfailed As Boolean
Dim iPCT As Long, ws2rw As Long, rWS1cr As Range, rWS2cr As Range, keyval As Variant, app As Application
Set app = Application
'UserForm1.Visible = True
app.ScreenUpdating = False
'DoEvents
With ws1.Cells(1, 1).CurrentRegion
Set rWS1cr = .Cells
ws1row = .Rows.Count
ws1col = .Columns.Count
End With
With ws2.Cells(1, 1).CurrentRegion
Set rWS2cr = .Cells
ws2row = .Rows.Count
ws2col = .Columns.Count
End With
maxrow = ws1row
maxcol = ws1col
'pk = UCase(TestDataComparator.TextBox1.Value)
For cl = 1 To maxcol
If pk = UCase(rWS1cr.Cells(1, cl).Value) Then
pki = cl
Exit For
End If
Next cl
If maxrow < ws2row Then maxrow = ws2row
If maxcol < ws2col Then maxcol = ws2col
difference = 0
reportrow = 0
With rWS1cr
For rw = 2 To maxrow
keyval = ws1.Cells(rw, 1).Value
If Not IsError(app.Match(keyval, rWS2cr.Columns(1), 0)) Then
ws2rw = app.Match(keyval, rWS2cr.Columns(1), 0)
flag = False
For cl = 2 To maxcol
counter = counter + 1
cell1 = vbNullString
cell2 = vbNullString
cell1 = .Cells(rw, cl).Value
cell2 = rWS2cr.Cells(ws2rw, cl).Value
If cell1 <> cell2 Then
flag = True
'diffcolname = .Cells(1, cl)
.Cells(rw, cl).Interior.Color = RGB(255, 255, 0)
.Cells(1, cl).Interior.Color = RGB(255, 0, 0)
.Cells(rw, cl).Font.Bold = True
.Cells(1, pki).Interior.Color = RGB(0, 255, 0)
.Cells(rw, pki).Interior.Color = RGB(255, 255, 0)
.Cells(rw, pki).Font.Color = RGB(255, 0, 0)
.Cells(rw, pki).Font.Bold = True
End If
Next cl
reportrow = reportrow - CLng(flag)
If iPCT <> CLng((rw / maxrow) * 100) Then
iPCT = CLng((rw / maxrow) * 100)
app.StatusBar = "Progress - " & Format(iPCT, "0\%")
End If
End If
Next rw
For cl = 1 To maxcol
If .Cells(1, cl).Interior.Color = RGB(255, 0, 0) Then
difference = difference + 1
'TestDataComparator.AttributeNameList.AddItem (ws1.Cells(1, col))
End If
Next cl
MsgBox difference & " columns contain different data! ", vbInformation, "Comparing Two Worksheets"
End With
difference = 0
app.ScreenUpdating = True
app.StatusBar = vbNullString
Set app = Nothing
End Sub
I prefer .CurrentRegion to .UsedRange as I find it more reliable. This code was not tested but it does compile and I had to comment out a number of external references to get that to happen.