Compare text in 2 separate spreadsheets, when match found display
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 |
Compare text in 2 separate spreadsheets, when match found display
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 |
Compare text in 2 separate spreadsheets, when match found disp
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 |
Compare text in 2 separate spreadsheets, when match found disp
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 |
All times are GMT +1. The time now is 01:22 AM. |
Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
ExcelBanter.com