Home Menu

Menu


ExcelBanter » Excel Newsgroups » Excel Programming > Compare two text files
Reply
 
LinkBack Thread Tools Search this Thread Display Modes
  #1   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 93
Default Compare two text files
As Tom Ogilvy said we use countif formula to compare two lists but if the
lists are long ( more than 10000 ) it take some time to do the job. This
macro Compare2Lists() is very fast and gives a comprehensive report.
In a new workbook with 3 sheets, Put the List1 in "Sheet1" columnA with a
header in A1,
List2 in "Sheet2" as above and put this code (all of them) in a general
module and run the macro
Compare2Lists()
Would like to here comments from interested parties, Please.
Cecil

Option Explicit

Sub Compare2Lists()

Dim LRow As Long
Sheets("Sheet3").Cells.Clear

GettingValues

Range("B1").Formula = "Tag"
'Find the last row with data
LRow = Range("A" & Rows.Count).End(xlUp).Row

'sort the list and tag the duplicates
Range("A1:B" & LRow).Sort Key1:=Range("A2"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom

TagDuplicates

FilterUniques_Duplicates

Indexing

Reporting

End Sub

Sub GettingValues()
Dim i As Single
Dim varr() As Variant
Application.ScreenUpdating = False

varr() = Array("L1", "L2")

For i = 1 To 2
Sheets("Sheet" & i).Select
Range("B1:Z" & Rows.Count).ClearContents
ExtractUniques_Duplicats

Sheets("Sheet3").Range("A1").Value = Range("A1").Value
Sheets("Sheet3").Range("B1").Value = varr(i - 1)

TagCases

Next i

Application.ScreenUpdating = True

Sheets("Sheet3").Select
End Sub

Sub ExtractUniques_Duplicats()
Dim LRow As Long
Dim LRDups As Long
Dim FRdEl As Long
Dim spt As Integer
Dim varr() As Variant
Dim i As Long
Dim j As Long
Application.ScreenUpdating = False

SortList

TagDuplicates

FilterUniques_Duplicates

'Tag the duplicates to delete while keeping the last one
LRDups = Range("L" & Rows.Count).End(xlUp).Row
With Range("O3")
.Formula = "=IF(N4=N3+1,""dEl"",N3)"
.AutoFill Destination:=Range("O3:O" & LRDups)
End With
With Range("O3:O" & LRDups)
.Copy
.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End With
Application.CutCopyMode = False

spt = 3
For i = 3 To LRDups
If IsNumeric(Range("O" & i).Value) Then
For j = spt To i
Range("P" & i).Value = Range("P" & i).Value & _
Range("M" & j).Value & ","
Next j
spt = i + 1
End If
Next i

Range(Cells(2, 12), Cells(LRDups, 16)).Sort _
Key1:=Range("O3"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

'Delete the duplicates but keep one of each
If Evaluate("Counta(L3:L5)") 1 Then
Range("A1").Select
Cells.Find(What:="dEl", After:=ActiveCell, _
LookIn:=xlFormulas, LookAt:= _
xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=True, SearchFormat:=False).Activate
FRdEl = ActiveCell.Row
Range("L" & FRdEl & ":P" & LRDups).ClearContents
End If
'Headers
Range("J1").Value = "Unique"
Range("L1").Value = "Duplicate"
Range("N2").Value = "Count"
Range("P2").Value = "InRows"

SortBack

'Cleanup
varr() = Array("C:I", "M", "O")
For i = UBound(varr()) To LBound(varr()) Step -1
Columns(varr(i)).Delete
Next i
Range("B1").EntireColumn.ClearContents
Range("A1").Select

Application.ScreenUpdating = True

End Sub


Sub SortList()
Dim LRow As Long
LRow = Range("A" & Rows.Count).End(xlUp).Row
'This macro will sort the list so
'Put an index column to sort back to the original
Range("B1").Formula = "Row"
With Range("B2")
.Formula = "=ROW()"
.AutoFill Destination:=Range("B2:B" & LRow)
End With
With Range("B2:B" & LRow)
.Copy
.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End With
Application.CutCopyMode = False
Range("A1:B" & LRow).Sort Key1:=Range("A2"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End Sub


Sub SortBack()
Dim LRow As Long
LRow = Range("A" & Rows.Count).End(xlUp).Row
'sort back the list
Range("A1:B" & LRow).Sort Key1:=Range("B2"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom

End Sub


Sub TagDuplicates()
Dim LRow As Long
LRow = Range("A" & Rows.Count).End(xlUp).Row

Range("C1").Formula = "1"
With Range("C2")
.Formula = "=IF(A2=A1,C1+1,1)"
.AutoFill Destination:=Range("C2:C" & LRow)
End With
Range("D1").Formula = "Unique"
With Range("D2")
.Formula = "=IF(C2=C3,1,0)"
.AutoFill Destination:=Range("D2:D" & LRow)
End With
With Range("C2:D" & LRow)
.Copy
.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End With
Application.CutCopyMode = False
If Range("C" & LRow).Value = 1 Then _
Range("D" & LRow).Value = 1

End Sub


Sub FilterUniques_Duplicates()
Dim LRow As Long
LRow = Range("A" & Rows.Count).End(xlUp).Row
'Use advanced filter to extract unique and duplicate list
Range("J2").Value = Range("A1").Value
Range("K2").Value = Range("B1").Value
Range("F2").Value = Range("D1").Value
Range("F3").Value = 1

Range("A1:D" & LRow).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("F2:F3"), _
CopyToRange:=Range("J2:K2"), unique:=False

Range("L2").Value = Range("A1").Value
Range("M2").Value = Range("B1").Value
Range("N2").Value = Range("C1").Value
Range("F3").Value = 0

Range("A1:D" & LRow).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("F2:F3"), _
CopyToRange:=Range("L2:N2"), unique:=False

End Sub

Sub TagCases()
Dim LRow As Long
Dim StRow As Long

LRow = Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Row
StRow = LRow + 1
If Evaluate("Counta(C3:C5)") 1 Then
Range(Range("C3"), _
Range("C3").End(xlDown)).Copy _
Destination:=Sheets("Sheet3").Range("A" & StRow)
Application.CutCopyMode = False
LRow = Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Sheet3").Range("B" & StRow).Value = _
Sheets("Sheet3").Range("B1").Value & "U"
Sheets("Sheet3").Range("B" & StRow).AutoFill _
Destination:=Sheets("Sheet3").Range("B" & StRow & ":B" & LRow)
StRow = LRow + 1
ElseIf Evaluate("Counta(C3:C5)") = 1 Then
Sheets("Sheet3").Range("A" & StRow).Value = Range("C3").Value
LRow = Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Sheet3").Range("B" & StRow).Value = _
Sheets("Sheet3").Range("B1").Value & "U"
StRow = LRow + 1
Else
LRow = Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Row
StRow = LRow + 1
End If

If Evaluate("Counta(E3:E5)") 1 Then
Range(Range("E3"), _
Range("E3").End(xlDown)).Copy _
Destination:=Sheets("Sheet3").Range("A" & StRow)
Application.CutCopyMode = False
LRow = Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Sheet3").Range("B" & StRow).Value = _
Sheets("Sheet3").Range("B1").Value & "D"
Sheets("Sheet3").Range("B" & StRow).AutoFill _
Destination:=Sheets("Sheet3").Range("B" & StRow & ":B" & LRow)
StRow = LRow + 1
ElseIf Evaluate("Counta(E3:E5)") = 1 Then
Sheets("Sheet3").Range("A" & StRow).Value = Range("E3").Value
LRow = Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Sheet3").Range("B" & StRow).Value = _
Sheets("Sheet3").Range("B1").Value & "D"
StRow = LRow + 1
Else
LRow = Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Row
StRow = LRow + 1
End If

End Sub


Sub Indexing()
Dim LRowDups As Long
Dim i As Long
Application.ScreenUpdating = False
LRowDups = Range("L" & Rows.Count).End(xlUp).Row
For i = LRowDups To 3 Step -1
If Range("L" & i).Value = Range("L" & i - 1).Value Then
Range("M" & i - 1).Value = _
Range("M" & i - 1).Value & Range("M" & i).Value
Range("M" & i).ClearContents
End If
Next i
Application.ScreenUpdating = True
End Sub


Sub Reporting()
Dim LRow As Long
Dim LRowDups As Long
Dim i As Long
Dim varr() As Variant
Dim legend() As Variant
Dim rng As Range
Application.ScreenUpdating = False
varr() = Array("L1U", "L1D", "L2U", "L2D", _
"L1UL2U", "L1UL2D", "L1DL2U", "L1DL2D")
Range("O2").Value = Range("B1").Value
LRow = Range("A" & Rows.Count).End(xlUp).Row
Range("A1:I" & LRow).ClearContents
LRow = Range("J" & Rows.Count).End(xlUp).Row
LRowDups = Range("L" & Rows.Count).End(xlUp).Row
Range("O2").Value = Range("K2").Value
Set rng = Range("J2:K" & LRow)
For i = 1 To 8
Cells(1, i).Value = varr(i - 1)
Range("O3").Value = varr(i - 1)
Cells(2, i).Value = Range("J2").Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("O2:O3"), _
CopyToRange:=Range(Chr(64 + i) & 2), unique:=False
If i = 4 Then
Set rng = Range("L2:M" & LRowDups)
End If
Next i
Range("J2:O" & LRow).EntireColumn.Delete
Range("A1").Select
legend() = Array( _
"Items unique to List1", _
"Items unique to List1 but appear more than once", _
"Items unique to List2", _
"Items unique to List2 but appear more than once", _
"Items appear once in both Lists", _
"Items appear once in list1 and more than once in List2", _
"Items appear once in list2 and more than once in List1", _
"Items appear more than once in both Lists")
For i = 0 To 7
Range("J" & i + 3).Value = varr(i)
Range("K" & i + 3).Value = legend(i)
Next i
Application.ScreenUpdating = True
End Sub



"LostinTransportation"
wrote in message ...
Have two text files that contain one column of one word names. Need to
find
the easiest way for a non-technical end-user to compare the two reports
and
find exceptions (i.e. any items that are on list A and not on list B, or
any
items that are on list B and not on list A).
--
TIA!


Reply With QuoteReply With Quote
  #2   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 2
Default Compare two text files
Cecil,
Cant get it to work, see post

"Compare2Lists" Macro Not working

Thanks

"Cecilkumara Fernando" wrote:

As Tom Ogilvy said we use countif formula to compare two lists but if the
lists are long ( more than 10000 ) it take some time to do the job. This
macro Compare2Lists() is very fast and gives a comprehensive report.
In a new workbook with 3 sheets, Put the List1 in "Sheet1" columnA with a
header in A1,
List2 in "Sheet2" as above and put this code (all of them) in a general
module and run the macro
Compare2Lists()
Would like to here comments from interested parties, Please.
Cecil

Option Explicit

Sub Compare2Lists()

Dim LRow As Long
Sheets("Sheet3").Cells.Clear

GettingValues

Range("B1").Formula = "Tag"
'Find the last row with data
LRow = Range("A" & Rows.Count).End(xlUp).Row

'sort the list and tag the duplicates
Range("A1:B" & LRow).Sort Key1:=Range("A2"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom

TagDuplicates

FilterUniques_Duplicates

Indexing

Reporting

End Sub

Sub GettingValues()
Dim i As Single
Dim varr() As Variant
Application.ScreenUpdating = False

varr() = Array("L1", "L2")

For i = 1 To 2
Sheets("Sheet" & i).Select
Range("B1:Z" & Rows.Count).ClearContents
ExtractUniques_Duplicats

Sheets("Sheet3").Range("A1").Value = Range("A1").Value
Sheets("Sheet3").Range("B1").Value = varr(i - 1)

TagCases

Next i

Application.ScreenUpdating = True

Sheets("Sheet3").Select
End Sub

Sub ExtractUniques_Duplicats()
Dim LRow As Long
Dim LRDups As Long
Dim FRdEl As Long
Dim spt As Integer
Dim varr() As Variant
Dim i As Long
Dim j As Long
Application.ScreenUpdating = False

SortList

TagDuplicates

FilterUniques_Duplicates

'Tag the duplicates to delete while keeping the last one
LRDups = Range("L" & Rows.Count).End(xlUp).Row
With Range("O3")
.Formula = "=IF(N4=N3+1,""dEl"",N3)"
.AutoFill Destination:=Range("O3:O" & LRDups)
End With
With Range("O3:O" & LRDups)
.Copy
.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End With
Application.CutCopyMode = False

spt = 3
For i = 3 To LRDups
If IsNumeric(Range("O" & i).Value) Then
For j = spt To i
Range("P" & i).Value = Range("P" & i).Value & _
Range("M" & j).Value & ","
Next j
spt = i + 1
End If
Next i

Range(Cells(2, 12), Cells(LRDups, 16)).Sort _
Key1:=Range("O3"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

'Delete the duplicates but keep one of each
If Evaluate("Counta(L3:L5)") 1 Then
Range("A1").Select
Cells.Find(What:="dEl", After:=ActiveCell, _
LookIn:=xlFormulas, LookAt:= _
xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=True, SearchFormat:=False).Activate
FRdEl = ActiveCell.Row
Range("L" & FRdEl & ":P" & LRDups).ClearContents
End If
'Headers
Range("J1").Value = "Unique"
Range("L1").Value = "Duplicate"
Range("N2").Value = "Count"
Range("P2").Value = "InRows"

SortBack

'Cleanup
varr() = Array("C:I", "M", "O")
For i = UBound(varr()) To LBound(varr()) Step -1
Columns(varr(i)).Delete
Next i
Range("B1").EntireColumn.ClearContents
Range("A1").Select

Application.ScreenUpdating = True

End Sub


Sub SortList()
Dim LRow As Long
LRow = Range("A" & Rows.Count).End(xlUp).Row
'This macro will sort the list so
'Put an index column to sort back to the original
Range("B1").Formula = "Row"
With Range("B2")
.Formula = "=ROW()"
.AutoFill Destination:=Range("B2:B" & LRow)
End With
With Range("B2:B" & LRow)
.Copy
.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End With
Application.CutCopyMode = False
Range("A1:B" & LRow).Sort Key1:=Range("A2"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End Sub


Sub SortBack()
Dim LRow As Long
LRow = Range("A" & Rows.Count).End(xlUp).Row
'sort back the list
Range("A1:B" & LRow).Sort Key1:=Range("B2"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom

End Sub


Sub TagDuplicates()
Dim LRow As Long
LRow = Range("A" & Rows.Count).End(xlUp).Row

Range("C1").Formula = "1"
With Range("C2")
.Formula = "=IF(A2=A1,C1+1,1)"
.AutoFill Destination:=Range("C2:C" & LRow)
End With
Range("D1").Formula = "Unique"
With Range("D2")
.Formula = "=IF(C2=C3,1,0)"
.AutoFill Destination:=Range("D2:D" & LRow)
End With
With Range("C2:D" & LRow)
.Copy
.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End With
Application.CutCopyMode = False
If Range("C" & LRow).Value = 1 Then _
Range("D" & LRow).Value = 1

End Sub


Sub FilterUniques_Duplicates()
Dim LRow As Long
LRow = Range("A" & Rows.Count).End(xlUp).Row
'Use advanced filter to extract unique and duplicate list
Range("J2").Value = Range("A1").Value
Range("K2").Value = Range("B1").Value
Range("F2").Value = Range("D1").Value
Range("F3").Value = 1

Range("A1:D" & LRow).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("F2:F3"), _
CopyToRange:=Range("J2:K2"), unique:=False

Range("L2").Value = Range("A1").Value
Range("M2").Value = Range("B1").Value
Range("N2").Value = Range("C1").Value
Range("F3").Value = 0

Range("A1:D" & LRow).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("F2:F3"), _
CopyToRange:=Range("L2:N2"), unique:=False

End Sub

Sub TagCases()
Dim LRow As Long
Dim StRow As Long

LRow = Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Row
StRow = LRow + 1
If Evaluate("Counta(C3:C5)") 1 Then
Range(Range("C3"), _
Range("C3").End(xlDown)).Copy _
Destination:=Sheets("Sheet3").Range("A" & StRow)
Application.CutCopyMode = False
LRow = Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Sheet3").Range("B" & StRow).Value = _
Sheets("Sheet3").Range("B1").Value & "U"
Sheets("Sheet3").Range("B" & StRow).AutoFill _
Destination:=Sheets("Sheet3").Range("B" & StRow & ":B" & LRow)
StRow = LRow + 1
ElseIf Evaluate("Counta(C3:C5)") = 1 Then
Sheets("Sheet3").Range("A" & StRow).Value = Range("C3").Value
LRow = Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Sheet3").Range("B" & StRow).Value = _
Sheets("Sheet3").Range("B1").Value & "U"
StRow = LRow + 1
Else
LRow = Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Row
StRow = LRow + 1
End If

If Evaluate("Counta(E3:E5)") 1 Then
Range(Range("E3"), _
Range("E3").End(xlDown)).Copy _
Destination:=Sheets("Sheet3").Range("A" & StRow)
Application.CutCopyMode = False
LRow = Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Sheet3").Range("B" & StRow).Value = _
Sheets("Sheet3").Range("B1").Value & "D"
Sheets("Sheet3").Range("B" & StRow).AutoFill _
Destination:=Sheets("Sheet3").Range("B" & StRow & ":B" & LRow)
StRow = LRow + 1
ElseIf Evaluate("Counta(E3:E5)") = 1 Then
Sheets("Sheet3").Range("A" & StRow).Value = Range("E3").Value
LRow = Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Sheet3").Range("B" & StRow).Value = _
Sheets("Sheet3").Range("B1").Value & "D"
StRow = LRow + 1
Else
LRow = Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Row
StRow = LRow + 1
End If

End Sub


Sub Indexing()
Dim LRowDups As Long
Dim i As Long
Application.ScreenUpdating = False
LRowDups = Range("L" & Rows.Count).End(xlUp).Row
For i = LRowDups To 3 Step -1
If Range("L" & i).Value = Range("L" & i - 1).Value Then
Range("M" & i - 1).Value = _
Range("M" & i - 1).Value & Range("M" & i).Value
Range("M" & i).ClearContents
End If
Next i
Application.ScreenUpdating = True
End Sub


Sub Reporting()
Dim LRow As Long
Dim LRowDups As Long
Dim i As Long
Dim varr() As Variant
Dim legend() As Variant
Dim rng As Range
Application.ScreenUpdating = False
varr() = Array("L1U", "L1D", "L2U", "L2D", _
"L1UL2U", "L1UL2D", "L1DL2U", "L1DL2D")
Range("O2").Value = Range("B1").Value
LRow = Range("A" & Rows.Count).End(xlUp).Row
Range("A1:I" & LRow).ClearContents
LRow = Range("J" & Rows.Count).End(xlUp).Row
LRowDups = Range("L" & Rows.Count).End(xlUp).Row
Range("O2").Value = Range("K2").Value
Set rng = Range("J2:K" & LRow)
For i = 1 To 8
Cells(1, i).Value = varr(i - 1)
Range("O3").Value = varr(i - 1)
Cells(2, i).Value = Range("J2").Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("O2:O3"), _
CopyToRange:=Range(Chr(64 + i) & 2), unique:=False
If i = 4 Then
Set rng = Range("L2:M" & LRowDups)
End If
Next i
Range("J2:O" & LRow).EntireColumn.Delete
Range("A1").Select
legend() = Array( _
"Items unique to List1", _
"Items unique to List1 but appear more than once", _
"Items unique to List2", _
"Items unique to List2 but appear more than once", _
"Items appear once in both Lists", _
"Items appear once in list1 and more than once in List2", _
"Items appear once in list2 and more than once in List1", _
"Items appear more than once in both Lists")
For i = 0 To 7
Range("J" & i + 3).Value = varr(i)
Range("K" & i + 3).Value = legend(i)
Next i
Application.ScreenUpdating = True
End Sub



"LostinTransportation"
wrote in message ...
Have two text files that contain one column of one word names. Need to
find
the easiest way for a non-technical end-user to compare the two reports
and
find exceptions (i.e. any items that are on list A and not on list B, or
any
items that are on list B and not on list A).
--
TIA!



Reply With QuoteReply With Quote
  #3   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 1,758
Default Compare two text files
You have a suggestion at your post in .misc.

B Schwarz wrote:

Cecil,
Cant get it to work, see post

"Compare2Lists" Macro Not working

Thanks

"Cecilkumara Fernando" wrote:

As Tom Ogilvy said we use countif formula to compare two lists but if the
lists are long ( more than 10000 ) it take some time to do the job. This
macro Compare2Lists() is very fast and gives a comprehensive report.
In a new workbook with 3 sheets, Put the List1 in "Sheet1" columnA with a
header in A1,
List2 in "Sheet2" as above and put this code (all of them) in a general
module and run the macro
Compare2Lists()
Would like to here comments from interested parties, Please.
Cecil

Option Explicit

Sub Compare2Lists()

Dim LRow As Long
Sheets("Sheet3").Cells.Clear

GettingValues

Range("B1").Formula = "Tag"
'Find the last row with data
LRow = Range("A" & Rows.Count).End(xlUp).Row

'sort the list and tag the duplicates
Range("A1:B" & LRow).Sort Key1:=Range("A2"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom

TagDuplicates

FilterUniques_Duplicates

Indexing

Reporting

End Sub

Sub GettingValues()
Dim i As Single
Dim varr() As Variant
Application.ScreenUpdating = False

varr() = Array("L1", "L2")

For i = 1 To 2
Sheets("Sheet" & i).Select
Range("B1:Z" & Rows.Count).ClearContents
ExtractUniques_Duplicats

Sheets("Sheet3").Range("A1").Value = Range("A1").Value
Sheets("Sheet3").Range("B1").Value = varr(i - 1)

TagCases

Next i

Application.ScreenUpdating = True

Sheets("Sheet3").Select
End Sub

Sub ExtractUniques_Duplicats()
Dim LRow As Long
Dim LRDups As Long
Dim FRdEl As Long
Dim spt As Integer
Dim varr() As Variant
Dim i As Long
Dim j As Long
Application.ScreenUpdating = False

SortList

TagDuplicates

FilterUniques_Duplicates

'Tag the duplicates to delete while keeping the last one
LRDups = Range("L" & Rows.Count).End(xlUp).Row
With Range("O3")
.Formula = "=IF(N4=N3+1,""dEl"",N3)"
.AutoFill Destination:=Range("O3:O" & LRDups)
End With
With Range("O3:O" & LRDups)
.Copy
.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End With
Application.CutCopyMode = False

spt = 3
For i = 3 To LRDups
If IsNumeric(Range("O" & i).Value) Then
For j = spt To i
Range("P" & i).Value = Range("P" & i).Value & _
Range("M" & j).Value & ","
Next j
spt = i + 1
End If
Next i

Range(Cells(2, 12), Cells(LRDups, 16)).Sort _
Key1:=Range("O3"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

'Delete the duplicates but keep one of each
If Evaluate("Counta(L3:L5)") 1 Then
Range("A1").Select
Cells.Find(What:="dEl", After:=ActiveCell, _
LookIn:=xlFormulas, LookAt:= _
xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=True, SearchFormat:=False).Activate
FRdEl = ActiveCell.Row
Range("L" & FRdEl & ":P" & LRDups).ClearContents
End If
'Headers
Range("J1").Value = "Unique"
Range("L1").Value = "Duplicate"
Range("N2").Value = "Count"
Range("P2").Value = "InRows"

SortBack

'Cleanup
varr() = Array("C:I", "M", "O")
For i = UBound(varr()) To LBound(varr()) Step -1
Columns(varr(i)).Delete
Next i
Range("B1").EntireColumn.ClearContents
Range("A1").Select

Application.ScreenUpdating = True

End Sub


Sub SortList()
Dim LRow As Long
LRow = Range("A" & Rows.Count).End(xlUp).Row
'This macro will sort the list so
'Put an index column to sort back to the original
Range("B1").Formula = "Row"
With Range("B2")
.Formula = "=ROW()"
.AutoFill Destination:=Range("B2:B" & LRow)
End With
With Range("B2:B" & LRow)
.Copy
.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End With
Application.CutCopyMode = False
Range("A1:B" & LRow).Sort Key1:=Range("A2"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End Sub


Sub SortBack()
Dim LRow As Long
LRow = Range("A" & Rows.Count).End(xlUp).Row
'sort back the list
Range("A1:B" & LRow).Sort Key1:=Range("B2"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom

End Sub


Sub TagDuplicates()
Dim LRow As Long
LRow = Range("A" & Rows.Count).End(xlUp).Row

Range("C1").Formula = "1"
With Range("C2")
.Formula = "=IF(A2=A1,C1+1,1)"
.AutoFill Destination:=Range("C2:C" & LRow)
End With
Range("D1").Formula = "Unique"
With Range("D2")
.Formula = "=IF(C2=C3,1,0)"
.AutoFill Destination:=Range("D2:D" & LRow)
End With
With Range("C2:D" & LRow)
.Copy
.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End With
Application.CutCopyMode = False
If Range("C" & LRow).Value = 1 Then _
Range("D" & LRow).Value = 1

End Sub


Sub FilterUniques_Duplicates()
Dim LRow As Long
LRow = Range("A" & Rows.Count).End(xlUp).Row
'Use advanced filter to extract unique and duplicate list
Range("J2").Value = Range("A1").Value
Range("K2").Value = Range("B1").Value
Range("F2").Value = Range("D1").Value
Range("F3").Value = 1

Range("A1:D" & LRow).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("F2:F3"), _
CopyToRange:=Range("J2:K2"), unique:=False

Range("L2").Value = Range("A1").Value
Range("M2").Value = Range("B1").Value
Range("N2").Value = Range("C1").Value
Range("F3").Value = 0

Range("A1:D" & LRow).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("F2:F3"), _
CopyToRange:=Range("L2:N2"), unique:=False

End Sub

Sub TagCases()
Dim LRow As Long
Dim StRow As Long

LRow = Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Row
StRow = LRow + 1
If Evaluate("Counta(C3:C5)") 1 Then
Range(Range("C3"), _
Range("C3").End(xlDown)).Copy _
Destination:=Sheets("Sheet3").Range("A" & StRow)
Application.CutCopyMode = False
LRow = Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Sheet3").Range("B" & StRow).Value = _
Sheets("Sheet3").Range("B1").Value & "U"
Sheets("Sheet3").Range("B" & StRow).AutoFill _
Destination:=Sheets("Sheet3").Range("B" & StRow & ":B" & LRow)
StRow = LRow + 1
ElseIf Evaluate("Counta(C3:C5)") = 1 Then
Sheets("Sheet3").Range("A" & StRow).Value = Range("C3").Value
LRow = Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Sheet3").Range("B" & StRow).Value = _
Sheets("Sheet3").Range("B1").Value & "U"
StRow = LRow + 1
Else
LRow = Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Row
StRow = LRow + 1
End If

If Evaluate("Counta(E3:E5)") 1 Then
Range(Range("E3"), _
Range("E3").End(xlDown)).Copy _
Destination:=Sheets("Sheet3").Range("A" & StRow)
Application.CutCopyMode = False
LRow = Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Sheet3").Range("B" & StRow).Value = _
Sheets("Sheet3").Range("B1").Value & "D"
Sheets("Sheet3").Range("B" & StRow).AutoFill _
Destination:=Sheets("Sheet3").Range("B" & StRow & ":B" & LRow)
StRow = LRow + 1
ElseIf Evaluate("Counta(E3:E5)") = 1 Then
Sheets("Sheet3").Range("A" & StRow).Value = Range("E3").Value
LRow = Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Sheet3").Range("B" & StRow).Value = _
Sheets("Sheet3").Range("B1").Value & "D"
StRow = LRow + 1
Else
LRow = Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Row
StRow = LRow + 1
End If

End Sub


Sub Indexing()
Dim LRowDups As Long
Dim i As Long
Application.ScreenUpdating = False
LRowDups = Range("L" & Rows.Count).End(xlUp).Row
For i = LRowDups To 3 Step -1
If Range("L" & i).Value = Range("L" & i - 1).Value Then
Range("M" & i - 1).Value = _
Range("M" & i - 1).Value & Range("M" & i).Value
Range("M" & i).ClearContents
End If
Next i
Application.ScreenUpdating = True
End Sub


Sub Reporting()
Dim LRow As Long
Dim LRowDups As Long
Dim i As Long
Dim varr() As Variant
Dim legend() As Variant
Dim rng As Range
Application.ScreenUpdating = False
varr() = Array("L1U", "L1D", "L2U", "L2D", _
"L1UL2U", "L1UL2D", "L1DL2U", "L1DL2D")
Range("O2").Value = Range("B1").Value
LRow = Range("A" & Rows.Count).End(xlUp).Row
Range("A1:I" & LRow).ClearContents
LRow = Range("J" & Rows.Count).End(xlUp).Row
LRowDups = Range("L" & Rows.Count).End(xlUp).Row
Range("O2").Value = Range("K2").Value
Set rng = Range("J2:K" & LRow)
For i = 1 To 8
Cells(1, i).Value = varr(i - 1)
Range("O3").Value = varr(i - 1)
Cells(2, i).Value = Range("J2").Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("O2:O3"), _
CopyToRange:=Range(Chr(64 + i) & 2), unique:=False
If i = 4 Then
Set rng = Range("L2:M" & LRowDups)
End If
Next i
Range("J2:O" & LRow).EntireColumn.Delete
Range("A1").Select
legend() = Array( _
"Items unique to List1", _
"Items unique to List1 but appear more than once", _
"Items unique to List2", _
"Items unique to List2 but appear more than once", _
"Items appear once in both Lists", _
"Items appear once in list1 and more than once in List2", _
"Items appear once in list2 and more than once in List1", _
"Items appear more than once in both Lists")
For i = 0 To 7
Range("J" & i + 3).Value = varr(i)
Range("K" & i + 3).Value = legend(i)
Next i
Application.ScreenUpdating = True
End Sub



"LostinTransportation"
wrote in message ...
Have two text files that contain one column of one word names. Need to
find
the easiest way for a non-technical end-user to compare the two reports
and
find exceptions (i.e. any items that are on list A and not on list B, or
any
items that are on list B and not on list A).
--
TIA!




--

Dave Peterson
Reply With QuoteReply With Quote
Reply
Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes
Linear Mode Linear Mode

Posting Rules
Smilies are On
[IMG] code is On
HTML code is Off
Trackbacks are On
Pingbacks are On
Refbacks are On

Similar Threads
Thread Thread Starter Forum Replies Last Post
Compare text in 2 different files Paige Wolfgram Excel Worksheet Functions 2 April 2nd 10 09:46 PM
How do i compare two different files Rasmus Excel Worksheet Functions 2 October 30th 08 07:14 PM
I Have two files that i need to compare? Daysi Excel Worksheet Functions 1 November 30th 05 06:30 AM
Compare two text files Tom Ogilvy Excel Programming 0 September 15th 04 04:52 PM
Bit to Bit Compare of Files? Ken Williams[_2_] Excel Programming 1 April 28th 04 11:19 PM


All times are GMT +1. The time now is 04:34 PM.

Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
Copyright ©2004-2024 ExcelBanter.
The comments are property of their posters.
 

About Us

"It's about Microsoft Excel"

 

Contact Us ExcelBanter forum home Privacy Statement