Cellen verplaatsen en kolommen overslaan

[bomseler]

Hallo allemaal,

Ik ben met een macro bezig om cellen op te schuiven naar links/rechts en naar onder/boven. Echter soms moet er een kolom worden overgeslagen. De macro voor het schuiven naar rechts heb ik al werkend gekregen met deze code:

Sub test_vooruit()

    Dim rc, c As Range, i As Long, j As Long
    Dim x As Long, y As Long
    Dim rng As Range
    Dim cnmb As Long, cl As Long
x = 1
y = 0
Set c = Selection

        For i = 1 To c.Rows.Count
          For j = c.Columns.Count To 1 Step -1
           With Cells(c.Rows(i).Row, c.Cells(j).Column)
            If .Value <> "" Then
             rc = Application.Match(False, Range(Cells(2, c.Columns(j).Column + x), "u2"), 0)
              If Not IsError(rc) Then
                .Offset(y, rc + x - 1) = Cells(c.Rows(i).Row, c.Cells(j).Column).Value
                .ClearContents
              End If
            End If
           End With
          Next j
        Next i


End Sub

Echter probeer ik deze nu ook om te draaien om de cellen ook naar links te kunnen schuiven. Zie code hieronder. Kan iemand mij zeggen wat ik fout doe?

Sub test_achteruit()

    Dim rc, c As Range, i As Long, j As Long
    Dim x As Long, y As Long
    Dim rng As Range
    Dim cnmb As Long, cl As Long

Set c = Selection
x = 1
y = 0

        For i = c.Rows.Count To 1 Step -1
          For j = 1 To c.Columns.Count
           With Cells(c.Rows(i).Row, c.Cells(j).Column)
            If .Value <> "" Then
             rc = Application.Match(False, Range("e2", Cells(2, c.Columns(j).Column + x)), -1)
              If Not IsError(rc) Then
                .Offset(y, rc + x - 1) = Cells(c.Rows(i).Row, c.Cells(j).Column).Value
                If Kopie = False Then
                .ClearContents
                End If
              End If
            End If
           End With
          Next j
        Next i


End Sub

Voorbeeldbestand in de bijlage.

 

[VenA]

Sub test_vooruit()
  ar = Range("A2").Resize(, Cells(2, Columns.Count).End(xlToLeft).Column)
  sc = 6
  With ActiveCell
    If .Column < sc Or .Column > UBound(ar, 2) Or .Row < 2 Or .Value = "" Then Exit Sub
    For j = .Column + 1 To UBound(ar, 2)
      If Not ar(1, j) Then
        Cells(.Row, j) = .Value
        .ClearContents
        Exit For
      End If
    Next j
  End With
End Sub

Sub test_achteruit()
  ar = Range("A2").Resize(, Cells(2, Columns.Count).End(xlToLeft).Column)
  sc = 6
  With ActiveCell
    If .Column < sc Or .Column > UBound(ar, 2) Or .Row < 2 Or .Value = "" Then Exit Sub
    For j = .Column - 1 To sc Step -1
      If Not ar(1, j) Then
        Cells(.Row, j) = .Value
        .ClearContents
        Exit For
      End If
    Next j
  End With
End Sub