Detect duplicated columns and delete them VBA - excel

Question

I have used the code below to duplicate columns based on the iteration number and to paste the required data in the required columns.
Sub collerinfo(endroit As Variant, iterat As Variant, Mot As String, DateDeb As Variant, DateFin As
Variant, nbjours As Double, Ref As Variant)
Dim iteration As Integer
Dim it As Integer
Dim recherche As String
Dim Line As Range
Dim NumDebut As Integer
Dim NumFin As Integer
Dim NumDernier As Integer
Dim dercol As Integer
iteration = CInt(iterat)
Select Case Mot
Case "CP"
'max iteration = 4
If iteration > 4 Then
MsgBox "Le " & iteration & "ième " & Mot & " du matricule " & Ref & " n'a pas pu être inscrit sur le fichier Excel"
Exit Sub
End If
If iteration > 1 Then
recherche = "Début CP (date)"
Set Line = Sheets("Navette").Rows("2").Find(What:=recherche, LookIn:=xlValues, lookat:=xlWhole)
If Not Line Is Nothing Then
NumDebut = Line.Column
End If
recherche = "Fin CP (choix)"
Set Line = Sheets("Navette").Rows("2").Find(What:=recherche, LookIn:=xlValues, lookat:=xlWhole)
If Not Line Is Nothing Then
NumFin = Line.Column
End If
'comprendre ce bout de code
dercol = Sheets("Navette").Cells(1, Cells.Columns.Count).End(xlToLeft).Column
For NumDernier = dercol To 1 Step -1
If Sheets("Navette").Cells(2, NumDernier) = "Fin CP (choix)" Then Exit For
Next NumDernier
If (NumDernier - NumDebut + 1) / 4 < iteration Then
Sheets("Navette").Select
Range(Columns(NumDebut), Columns(NumFin)).Select
Selection.Copy
Columns(NumDernier + 1).Select
Selection.Insert Shift:=xlToRight
End If
End If
Dim ResCP As Variant
ResCP = Application.Match("Début CP (date)", Sheets("Navette").Rows(2), 0)
Sheets("Navette").Cells(endroit, ResCP + (iteration - 1) * 4).Value = DateDeb
Sheets("Navette").Cells(endroit, (ResCP + 1) + (iteration - 1) * 4).Value = nbjours
Sheets("Navette").Cells(endroit, (ResCP + 2) + (iteration - 1) * 4).Value = DateFin
Case "RTT"
If iteration > 4 Then
MsgBox "Le " & iteration & "ième " & Mot & " du matricule " & Ref & " n'a pas pu être inscrit sur le fichier Excel"
Exit Sub
End If
' revoir code
If iteration > 1 Then
recherche = "Début RTT (date)"
Set Line = Sheets("Navette").Rows("2").Find(What:=recherche, LookIn:=xlValues, lookat:=xlWhole)
If Not Line Is Nothing Then
NumDebut = Line.Column
End If
recherche = "Fin RTT (choix)"
Set Line = Sheets("Navette").Rows("2").Find(What:=recherche, LookIn:=xlValues, lookat:=xlWhole)
If Not Line Is Nothing Then
NumFin = Line.Column
End If
'comprendre ce bout de code
dercol = Sheets("Navette").Cells(1, Cells.Columns.Count).End(xlToLeft).Column
For NumDernier = dercol To 1 Step -1
If Sheets("Navette").Cells(2, NumDernier) = "Fin RTT (choix)" Then Exit For
Next NumDernier
If (NumDernier - NumDebut + 1) / 4 < iteration Then
Sheets("Navette").Select
Range(Columns(NumDebut), Columns(NumFin)).Select
Selection.Copy
Columns(NumDernier + 1).Select
Selection.Insert Shift:=xlToRight
End If
End If
End Select
End Sub
After data has been pasted, how do I restore the sheet, i.e, delete the added columns and data?
For instance, after adding the columns, the headers look like this :
A A1 A2 A A1 A2 A A1 A2 B B1 B2 B B1 B2
And in the end, I want it to be as follows :
A A1 A2 B B1 B2
Any suggestions ?

Answer 1

Try this. I have assumed the headers are in row 1 so might need adjusting.
Sub x()
Dim r As Range, i As Long
Set r = Range(Cells(1, 1), Cells(1, Columns.Count).End(xlToLeft))
For i = r.Count To 2 Step -1
If IsNumeric(Application.Match(r.Cells(i), r.Resize(, i - 1), 0)) Then 'header is found in the range to the left so delete this one
r.Cells(i).Delete shift:=xlToLeft 'just the cell
'r.Cells(i).entirecolumn.Delete 'whole column
End If
Next i
End Sub

Answer 2

Let us assume that the Headers appears in row 1. Try the below:
Option Explicit
Sub Macro1()
Dim LastColumn As Long, i As Long
Dim Columns As String
Columns = ""
With ThisWorkbook.Worksheets("Sheet1")
'Find last column of row 1
LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
'Loop columns
For i = 1 To LastColumn
'Check if the value appears twice
If WorksheetFunction.CountIf(.Range(.Cells(1, 1), .Cells(1, i)), .Cells(1, i).Value) > 1 Then
'Pass the dublicate value in a split converting the column number the dublicate found into a letter
If Columns = "" Then
Columns = Split(.Cells(1, i).Address, "$")(1) & ":" & Split(.Cells(1, i).Address, "$")(1)
Else
Columns = Columns & "," & Split(.Cells(1, i).Address, "$")(1) & ":" & Split(.Cells(1, i).Address, "$")(1)
End If
End If
Next i
'If the Columns are not empty delete the imported columns
If Columns <> "" Then
.Range(Columns).Delete Shift:=xlToLeft
End If
End With
End Sub