检测重复的列并删除它们 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

让我们假设标题出现在第 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