检测重复的列并将其删除VBA

Question

我使用下面的代码根据迭代次数复制列，并将所需数据粘贴到所需列中。

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

粘贴数据后，如何恢复工作表，即删除添加的列和数据？

例如，添加列后，标题如下所示：

A     A1     A2     A     A1     A2     A     A1     A2     B     B1     B2     B     B1     B2

最后，我希望它如下：

A    A1     A2     B     B1     B2

有什么建议吗？

Answer 1

试试这个。我假设标题在第1行，所以可能需要调整。

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

让我们假设Headers出现在第1行。尝试以下操作：

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