I'm trying to compare "name" in [sheet1] (where EType.sheet1 = constant), to
name in [sheet2] (where UType.sheet2 equals constant), and write the results
to another sheet.
The "name" in both sheets is a column list of names which may be duplicates,
but only want unique results.
Names only become applicable if EType.sheet1=constant1 and
UType.sheet2=constant2 is true.
Both lists contain blanks and text.
can anyone help and understand me ;-) Needed quite urgently, cheers

I found this Macro on this DG a while back. It works, but it hangs. I
haven't been able to 'fix' it yet...

Sub FindDupes()
Dim sht1 As Worksheet
Dim sht2 As Worksheet

Dim cell1 As Range
Dim cell2 As Range

Dim str As String
str = InputBox("Type name of first sheet")
Set sht1 = Worksheets(str)
str = InputBox("Type name of second sheet")
Set sht2 = Worksheets(str)

For Each cell1 In sht1.Columns(1).Cells
For Each cell2 In sht2.Columns(1).Cells
For Each cell3 In sht3.Columns(1).Cells
If cell2.Value = cell1.Value Then
cell1.Interior.ColorIndex = 5
cell2.Interior.ColorIndex = 3
End If

Next cell2
Next cell1
End Sub



As an alternative, this may do what you want:
Sub TestCompareWorksheets()
' compare two different worksheets in the active workbook
CompareWorksheets Worksheets("Sheet1"), Worksheets("Sheet2")
' compare two different worksheets in two different workbooks
' CompareWorksheets ActiveWorkbook.Worksheets("Sheet1"), _
Workbooks("WorkBookName.xls").Worksheets("Sheet2")
End Sub



Sub CompareWorksheets(ws1 As Worksheet, ws2 As Worksheet)
Dim r As Long, c As Integer
Dim lr1 As Long, lr2 As Long, lc1 As Integer, lc2 As Integer
Dim maxR As Long, maxC As Integer, cf1 As String, cf2 As String
Dim rptWB As Workbook, DiffCount As Long
Application.ScreenUpdating = False
Application.StatusBar = "Creating the report..."
Set rptWB = Workbooks.Add
Application.DisplayAlerts = False
While Worksheets.Count 1
Worksheets(2).Delete
Wend
Application.DisplayAlerts = True
With ws1.UsedRange
lr1 = .Rows.Count
lc1 = .Columns.Count
End With
With ws2.UsedRange
lr2 = .Rows.Count
lc2 = .Columns.Count
End With
maxR = lr1
maxC = lc1
If maxR < lr2 Then maxR = lr2
If maxC < lc2 Then maxC = lc2
DiffCount = 0
For c = 1 To maxC
Application.StatusBar = "Comparing cells " & Format(c / maxC, "0 %")
& "..."
For r = 1 To maxR
cf1 = ""
cf2 = ""
On Error Resume Next
cf1 = ws1.Cells(r, c).FormulaLocal
cf2 = ws2.Cells(r, c).FormulaLocal
On Error GoTo 0
If cf1 < cf2 Then
DiffCount = DiffCount + 1
Cells(r, c).Formula = "'" & cf1 & " < " & cf2
End If
Next r
Next c
Application.StatusBar = "Formatting the report..."
With Range(Cells(1, 1), Cells(maxR, maxC))
.Interior.ColorIndex = 19
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
On Error Resume Next
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
On Error GoTo 0
End With
Columns("A:IV").ColumnWidth = 20
rptWB.Saved = True
If DiffCount = 0 Then
rptWB.Close False
End If
Set rptWB = Nothing
Application.StatusBar = False
Application.ScreenUpdating = True
MsgBox DiffCount & " cells contain different formulas!", vbInformation, _
"Compare " & ws1.Name & " with " & ws2.Name
End Sub




Regards,
Ryan---

--
RyGuy


"cocoblue" wrote:

I'm trying to compare "name" in [sheet1] (where EType.sheet1 = constant), to
name in [sheet2] (where UType.sheet2 equals constant), and write the results
to another sheet.
The "name" in both sheets is a column list of names which may be duplicates,
but only want unique results.
Names only become applicable if EType.sheet1=constant1 and
UType.sheet2=constant2 is true.
Both lists contain blanks and text.
can anyone help and understand me ;-) Needed quite urgently, cheers

Thanks for the sugestions. I was not able to use them this time around.
cheers
Keith

"ryguy7272" wrote:

I found this Macro on this DG a while back. It works, but it hangs. I
haven't been able to 'fix' it yet...

Sub FindDupes()
Dim sht1 As Worksheet
Dim sht2 As Worksheet

Dim cell1 As Range
Dim cell2 As Range

Dim str As String
str = InputBox("Type name of first sheet")
Set sht1 = Worksheets(str)
str = InputBox("Type name of second sheet")
Set sht2 = Worksheets(str)

For Each cell1 In sht1.Columns(1).Cells
For Each cell2 In sht2.Columns(1).Cells
For Each cell3 In sht3.Columns(1).Cells
If cell2.Value = cell1.Value Then
cell1.Interior.ColorIndex = 5
cell2.Interior.ColorIndex = 3
End If

Next cell2
Next cell1
End Sub



As an alternative, this may do what you want:
Sub TestCompareWorksheets()
' compare two different worksheets in the active workbook
CompareWorksheets Worksheets("Sheet1"), Worksheets("Sheet2")
' compare two different worksheets in two different workbooks
' CompareWorksheets ActiveWorkbook.Worksheets("Sheet1"), _
Workbooks("WorkBookName.xls").Worksheets("Sheet2")
End Sub



Sub CompareWorksheets(ws1 As Worksheet, ws2 As Worksheet)
Dim r As Long, c As Integer
Dim lr1 As Long, lr2 As Long, lc1 As Integer, lc2 As Integer
Dim maxR As Long, maxC As Integer, cf1 As String, cf2 As String
Dim rptWB As Workbook, DiffCount As Long
Application.ScreenUpdating = False
Application.StatusBar = "Creating the report..."
Set rptWB = Workbooks.Add
Application.DisplayAlerts = False
While Worksheets.Count 1
Worksheets(2).Delete
Wend
Application.DisplayAlerts = True
With ws1.UsedRange
lr1 = .Rows.Count
lc1 = .Columns.Count
End With
With ws2.UsedRange
lr2 = .Rows.Count
lc2 = .Columns.Count
End With
maxR = lr1
maxC = lc1
If maxR < lr2 Then maxR = lr2
If maxC < lc2 Then maxC = lc2
DiffCount = 0
For c = 1 To maxC
Application.StatusBar = "Comparing cells " & Format(c / maxC, "0 %")
& "..."
For r = 1 To maxR
cf1 = ""
cf2 = ""
On Error Resume Next
cf1 = ws1.Cells(r, c).FormulaLocal
cf2 = ws2.Cells(r, c).FormulaLocal
On Error GoTo 0
If cf1 < cf2 Then
DiffCount = DiffCount + 1
Cells(r, c).Formula = "'" & cf1 & " < " & cf2
End If
Next r
Next c
Application.StatusBar = "Formatting the report..."
With Range(Cells(1, 1), Cells(maxR, maxC))
.Interior.ColorIndex = 19
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
On Error Resume Next
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
On Error GoTo 0
End With
Columns("A:IV").ColumnWidth = 20
rptWB.Saved = True
If DiffCount = 0 Then
rptWB.Close False
End If
Set rptWB = Nothing
Application.StatusBar = False
Application.ScreenUpdating = True
MsgBox DiffCount & " cells contain different formulas!", vbInformation, _
"Compare " & ws1.Name & " with " & ws2.Name
End Sub




Regards,
Ryan---

--
RyGuy


"cocoblue" wrote:

I'm trying to compare "name" in [sheet1] (where EType.sheet1 = constant), to
name in [sheet2] (where UType.sheet2 equals constant), and write the results
to another sheet.
The "name" in both sheets is a column list of names which may be duplicates,
but only want unique results.
Names only become applicable if EType.sheet1=constant1 and
UType.sheet2=constant2 is true.
Both lists contain blanks and text.
can anyone help and understand me ;-) Needed quite urgently, cheers

what i need if you can help is the excel functions to do this;

if row1.col1 isin row1.col2 and ((if row1.col3 = x then highlight row1.col1
with 1) or (if row1.col4 = x then highlight row1.col1 with 2))

this needs to test all text items in col1 against all text items in col2

if you can help

cheers


"cocoblue" wrote:

Thanks for the sugestions. I was not able to use them this time around.
cheers
Keith

"ryguy7272" wrote:

I found this Macro on this DG a while back. It works, but it hangs. I
haven't been able to 'fix' it yet...

Sub FindDupes()
Dim sht1 As Worksheet
Dim sht2 As Worksheet

Dim cell1 As Range
Dim cell2 As Range

Dim str As String
str = InputBox("Type name of first sheet")
Set sht1 = Worksheets(str)
str = InputBox("Type name of second sheet")
Set sht2 = Worksheets(str)

For Each cell1 In sht1.Columns(1).Cells
For Each cell2 In sht2.Columns(1).Cells
For Each cell3 In sht3.Columns(1).Cells
If cell2.Value = cell1.Value Then
cell1.Interior.ColorIndex = 5
cell2.Interior.ColorIndex = 3
End If

Next cell2
Next cell1
End Sub



As an alternative, this may do what you want:
Sub TestCompareWorksheets()
' compare two different worksheets in the active workbook
CompareWorksheets Worksheets("Sheet1"), Worksheets("Sheet2")
' compare two different worksheets in two different workbooks
' CompareWorksheets ActiveWorkbook.Worksheets("Sheet1"), _
Workbooks("WorkBookName.xls").Worksheets("Sheet2")
End Sub



Sub CompareWorksheets(ws1 As Worksheet, ws2 As Worksheet)
Dim r As Long, c As Integer
Dim lr1 As Long, lr2 As Long, lc1 As Integer, lc2 As Integer
Dim maxR As Long, maxC As Integer, cf1 As String, cf2 As String
Dim rptWB As Workbook, DiffCount As Long
Application.ScreenUpdating = False
Application.StatusBar = "Creating the report..."
Set rptWB = Workbooks.Add
Application.DisplayAlerts = False
While Worksheets.Count 1
Worksheets(2).Delete
Wend
Application.DisplayAlerts = True
With ws1.UsedRange
lr1 = .Rows.Count
lc1 = .Columns.Count
End With
With ws2.UsedRange
lr2 = .Rows.Count
lc2 = .Columns.Count
End With
maxR = lr1
maxC = lc1
If maxR < lr2 Then maxR = lr2
If maxC < lc2 Then maxC = lc2
DiffCount = 0
For c = 1 To maxC
Application.StatusBar = "Comparing cells " & Format(c / maxC, "0 %")
& "..."
For r = 1 To maxR
cf1 = ""
cf2 = ""
On Error Resume Next
cf1 = ws1.Cells(r, c).FormulaLocal
cf2 = ws2.Cells(r, c).FormulaLocal
On Error GoTo 0
If cf1 < cf2 Then
DiffCount = DiffCount + 1
Cells(r, c).Formula = "'" & cf1 & " < " & cf2
End If
Next r
Next c
Application.StatusBar = "Formatting the report..."
With Range(Cells(1, 1), Cells(maxR, maxC))
.Interior.ColorIndex = 19
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
On Error Resume Next
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
On Error GoTo 0
End With
Columns("A:IV").ColumnWidth = 20
rptWB.Saved = True
If DiffCount = 0 Then
rptWB.Close False
End If
Set rptWB = Nothing
Application.StatusBar = False
Application.ScreenUpdating = True
MsgBox DiffCount & " cells contain different formulas!", vbInformation, _
"Compare " & ws1.Name & " with " & ws2.Name
End Sub




Regards,
Ryan---

--
RyGuy


"cocoblue" wrote:

I'm trying to compare "name" in [sheet1] (where EType.sheet1 = constant), to
name in [sheet2] (where UType.sheet2 equals constant), and write the results
to another sheet.
The "name" in both sheets is a column list of names which may be duplicates,
but only want unique results.
Names only become applicable if EType.sheet1=constant1 and
UType.sheet2=constant2 is true.
Both lists contain blanks and text.
can anyone help and understand me ;-) Needed quite urgently, cheers