Обнаружить дублированные столбцы и удалить их VBA - PullRequest
Новая
       15

Обнаружить дублированные столбцы и удалить их VBA

0 голосов
/ 21 апреля 2020

Я использовал приведенный ниже код для дублирования столбцов на основе номера итерации и для вставки необходимых данных в необходимые столбцы. 

 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

Есть предложения?

Ответы [ 2 ]

0 голосов
/ 21 апреля 2020

Попробуйте это. Я предположил, что заголовки находятся в строке 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
0 голосов
/ 21 апреля 2020

Предположим, что заголовки появляются в строке 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
...