Column Uniquing In Excel Via VBScript
This script takes two Columns and finds those values which are in the first but not the second and those in the second and not the first. It places the unique values in two new columns in a new Sheet. This script is similar to those described in Baby Steps p48 on 'Merging Between Workbooks'.
This is a drag-and-drop script. To run, place the script on your desktop and 'drop' the Excel Workbook file on it (also, see the book for details).
Option Explicit
' Before running this script, please set these constants
' ======================================================
' Set this to the name of the input sheet
Const InputSheet="Sheet1"
' Set this to the first column in the column to column comparison
Const FirstColumn="A"
' Set this to the first column in the column to column comparison
Const SecondColumn="C"
' Set this to the number of rows to compare
Const NRows=19
' Set this the name of the output sheet
Const NewSheetName="Comparison"
' Set to TRUE if case is to be ignored in comparisons, FALSE otherwise
Const IgnoreCase=TRUE
' Set To TRUE if the input columns have colums headers
Const Headers=TRUE
' Do not edit below this line
' ===========================
Dim myExcel,myWorkbook,isheet,outputSheet
Dim fDictionary,sDictionary,outRow,key,value,row
Set myExcel=CreateObject("Excel.Application")
myExcel.Visible=TRUE
Set myWorkbook = myExcel.Workbooks.Open(WScript.Arguments(0))
Set fDictionary=CreateObject("Scripting.Dictionary")
Set sDictionary=CreateObject("Scripting.Dictionary")
Set isheet=myWorkbook.Sheets(Inputsheet)
Set outputSheet=myWorkbook.Sheets.Add()
outputSheet.Name=NewSheetName
outputSheet.Cells(1,1).Value="Unique To First"
outputSheet.Cells(1,2).Value="Unique To Second"
If Headers Then
row=2
Else
row=1
End if
For row=row to NRows+row-1
value=isheet.Range(FirstColumn & row).Value
If IgnoreCase Then
key=UCase(Trim(value))
Else
key=Trim(value)
End If
If Not fDictionary.Exists(key) Then
fDictionary.Add key,value
End If
value=isheet.Range(SecondColumn & row).Value
If IgnoreCase Then
key=UCase(Trim(value))
Else
key=Trim(value)
End If
If Not sDictionary.Exists(key) Then
sDictionary.Add key,value
End If
Next
outRow=2
For Each key in fDictionary.Keys
If Not sDictionary.Exists(key) Then
outputSheet.Cells(outRow,1).Value=fDictionary.Item(key)
outRow=outRow+1
End if
Next
outRow=2
For Each key in sDictionary.Keys
If Not fDictionary.Exists(key) Then
outputSheet.Cells(outRow,2).Value=sDictionary.Item(key)
outRow=outRow+1
End if
Next
outputSheet.Columns("A:B").AutoFilter
outputSheet.Range("A2:B" & outRow-1).Sort outputSheet.Range("A2")
outputSheet.Columns("A:B").Autofit
WScript.Echo "All done"
[Via]