Narly one...compare columns with other columns

B

beatrice25

Hi Everyone,
I have a sheet with hundreds of columns of data. I want to find out
which columns are repeated as it is likely that in many cases there
will be duplicate entries of columns with the same data (I want to
remove these). Each column has approx 300 rows and each cell within the
column contains either numbers, text, or numbers and text.

Any ideas?
Is it possible to concatenate the values in a whole column easily as
this would help. I could then use a concatenated "word" and compare it
to "words" of other columns making my problem 300 x easier!!

Thanks

B
 
M

macropod

Hi Beatrice,

For Excel, it's not all that hard with a bit of vba. The first two are
generic subs for maximising speed and giving feedback via the status bar.
The real work is done by the DeleteDuplicateColumns sub.


Option Explicit
Dim SBar As Boolean

Private Sub MacroEntry()
SBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Application.ScreenUpdating = False
Application.Calculation = xlManual
End Sub

Private Sub MacroExit()
Application.Calculation = xlAutomatic
Application.StatusBar = False
Application.DisplayStatusBar = SBar
Application.ScreenUpdating = True
End Sub

Sub DeleteDuplicateColumns()
Dim lLastRow As Long
Dim lLastCol As Long
Dim I As Long
Dim J As Long
Dim K As Long
Dim L As Long
Call MacroEntry
LastRow = ActiveSheet.UsedRange.Rows.Count - 1
LastCol = ActiveSheet.UsedRange.Columns.Count - 1
For I = 0 To LastCol - 1
Application.StatusBar = "Testing Columns: " & I & " " & lLastCol - J
For J = LastCol To I + 1 Step -1
For K = 0 To LastRow
If ActiveSheet.Range("A1").Offset(K, I).Value <> _
ActiveSheet.Range("A1").Offset(K, J).Value Then
Exit For
Next K
If K > LastRow Then
ActiveSheet.Range("A1").Offset(0, J).EntireColumn.Delete
L = L + 1
End If
Next J
If L + J = LastRow Then Exit For
Next I
Call MacroExit
End Sub


Cheers
 
B

beatrice25

Hi Macropod,
thank you very very much for the macros. The deleteduplicatecolumn
macro doesnt seem to run. I keep getting syntax error on
Exit
For
Next K

where FOR is red

Any ideas

Thanks again

Beatrice
 
M

macropod

Hi Beatrice,

Sorry about that, there's a few stray characters in the code I posted, left
over from dev/testing, plus one or two that don't seem to have made it into
my previous post.

Try this for the DeleteDuplicateColumns sub (with the other two):

Sub DeleteDuplicateColumns()
Dim LastRow As Long
Dim LastCol As Long
Dim I As Long
Dim J As Long
Dim K As Long
Dim L As Long
Call MacroEntry
LastRow = ActiveSheet.UsedRange.Rows.Count - 1
LastCol = ActiveSheet.UsedRange.Columns.Count - 1
For I = 0 To LastCol - 1
Application.StatusBar = "Testing Columns: " & I & " " & LastCol - J
For J = LastCol To I + 1 Step -1
For K = 0 To LastRow
If ActiveSheet.Range("A1").Offset(K, I).Value <> _
ActiveSheet.Range("A1").Offset(K, J).Value Then _
Exit For
Next K
If K > LastRow Then
ActiveSheet.Range("A1").Offset(0, J).EntireColumn.Delete
L = L + 1
End If
Next J
If L + J = LastRow Then Exit For
Next I
Call MacroExit
End Sub
 
B

beatrice25

Thanks for fixing the macro!!!
Just to verify, looking at the code, this macro will delete duplicate
columns. By delting them it will shif the other columns along. What I
need to do first is cut row 1 off (which has unique names for each
columns then paste it back once the macro has run. Therefore I think I
need to CLEAR the columns instead of deleting them so that when I paste
the names back they are in the right place.
To do this can I just change EntireColumn.Delete to
EntireColumn.clear?
It seems to work when I run it!

Thanks agian
Beatrice
 
M

macropod

Damn, this time for sure:

Sub DeleteDuplicateColumns()
Dim LastRow As Long
Dim LastCol As Long
Dim I As Long
Dim J As Long
Dim K As Long
Dim L As Long
L = 0
Call MacroEntry
LastRow = ActiveSheet.UsedRange.Rows.Count - 1
LastCol = ActiveSheet.UsedRange.Columns.Count - 1
For I = 0 To LastCol - 1
For J = LastCol To I + 1 Step -1
Application.StatusBar = "Testing Columns: " & I & " " &
LastCol - J
For K = 0 To LastRow
If ActiveSheet.Range("A1").Offset(K, I).Value <> _
ActiveSheet.Range("A1").Offset(K, J).Value Then _
Exit For
Next K
If K > LastRow Then
ActiveSheet.Range("A1").Offset(0, J).EntireColumn.Delete
L = L + 1
End If
Next J
If L + J = LastCol Then Exit For
Next I
Call MacroExit
End Sub

--
macropod
[MVP - Microsoft Word]


macropod said:
Hi Beatrice,

Sorry about that, there's a few stray characters in the code I posted, left
over from dev/testing, plus one or two that don't seem to have made it into
my previous post.

Try this for the DeleteDuplicateColumns sub (with the other two):

Sub DeleteDuplicateColumns()
Dim LastRow As Long
Dim LastCol As Long
Dim I As Long
Dim J As Long
Dim K As Long
Dim L As Long
Call MacroEntry
LastRow = ActiveSheet.UsedRange.Rows.Count - 1
LastCol = ActiveSheet.UsedRange.Columns.Count - 1
For I = 0 To LastCol - 1
Application.StatusBar = "Testing Columns: " & I & " " & LastCol - J
For J = LastCol To I + 1 Step -1
For K = 0 To LastRow
If ActiveSheet.Range("A1").Offset(K, I).Value <> _
ActiveSheet.Range("A1").Offset(K, J).Value Then _
Exit For
Next K
If K > LastRow Then
ActiveSheet.Range("A1").Offset(0, J).EntireColumn.Delete
L = L + 1
End If
Next J
If L + J = LastRow Then Exit For
Next I
Call MacroExit
End Sub

--
macropod
[MVP - Microsoft Word]


in message news:[email protected]...
Click to expand...
 
M

macropod

Hi Beatrice,

Since you've got unique column headings, presumably just on row 1, you'll
need to change the line:
For K = 0 To LastRow
to:
For K = 1 To LastRow
so that the column headings are ignored when evaluating whether the data
below the headings match. If your column headings span more than one row,
change the '1' to however many rows are used for them.

Unless you need to keep the original column headings and positions, there's
no need to do anything more - everything will be shifted along to the left.
If you do need to keep the original column headings and positions, change
the line:

ActiveSheet.Range("A1").Offset(0, J).EntireColumn.Delete
to:
ActiveSheet.Range(Range("A1").Offset(1, J).Address & ":" _
& Range("A1").Offset(LastRow - 1, J).Address).ClearContents


Cheers
 
B

beatrice25

Hi Macropod,
thanks for all this code too, you are a star! I will try it out today
when I get time

Cheers

B
 
Top