VBA-Makro Zellen verschieben

[Addi2020]

Hallo zusammen ich steh total auf dem Schlauch :17: ich habe Daten aus einer Tabelle aus SAP über Acrobat nach Excel exportiert. Die ausgelesenen Daten sollen (in die richtigen Spalten) in Excel eingeordnet werden.
Ich möchte die Tabelle in der Spalte N nach einem gewissen Kriterium filtern und dann in den gefilterten Zellen den Wert (Datum) der aus der Spalte N nach Spalte L (Zellen sind leer) verschoben wird (=> zwei Spalten nach links). Anschließend sollen noch die Werte der selben Zeile von Spalte O-T nach Spalte N-S verschoben werden (=> eine Spalte nach links). Die "ausgeblendeten" Zeilen dürfen nicht mit verschoben o.a. werden, da diese die gewünschte Spaltenstruktur schon haben. das Filterkriterium wird (soll) anschließend im VBA manuell angepasst werden. Die Orginaltabelle hat insgesamt über 100.000 Datensätze aus SAP. Aus den unten beigefügten Makros wollte ich mir irgendetwas zusammenbasteln.

Code:

Sub NurGefilterteKopieren()

  Dim tblRow1 As Integer, lRow As Integer
  Dim tblName As String
  tblName = "Mappe1"
  tblRow1 = Range(Tabelle1).Row
  With ListObjects(tblName)
      lRow = .ListRows.Count + 1
      .Range.AutoFilter Field:=14, Operator:= _
        xlFilterValues, Criteria2:=Array(0, "12/31/2001")
      Range("N" & tblRow1 - 2).Copy
      End With
  End Sub 

Sub Makro1()

Dim i As Integer
    ActiveSheet.Range("$A$1:$AC$101656").AutoFilter Field:=14, Operator:= _
        xlFilterValues, Criteria2:=Array(0, "12/31/2001")
    Range("N16861").Select
    Selection.Cut Destination:=Range("L16861")
    Range("O16861:T16861").Select
    Selection.Cut Destination:=Range("N16861:S16861")
    Range("N16861:S16861").Select
End Sub

Sub Zeilen_C_markieren()

Dim rngFilterCell As Range
For Each rngFilterCell In Range("n2:n" & Range("n101656").End(xlUp).Row).SpecialCells(12)
Range(rngFilterCell.Address).Select
MsgBox "SoSo"
Next
End Sub

Hoffentlich könnt ihr mir helfen :D 
Danke & Gruß Addi

[Raoul21]

Hi Addi

dieser Code, den Du in ein Modul einfügst, verschiebt von allen nach Filterung sichtbaren Zeilen die Zelle N nach L und die Zellen O:T nach N:S.

Code:

Sub Filterung()
   
    Dim b As Range
    Set b = Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible)
   
    Dim a As Range
    For Each a In b.Areas
       
        Dim d As Range
        For Each d In a.Rows
            With d
                If .Row <> 1 Then
               
                    .Cells(1, "N").Copy .Cells(1, "L")
                    .Range(Cells(1, "O"), Cells(1, "T")).Copy .Cells(1, "N")
                    .Cells(1, "T").Clear
                   
                End If
            End With
        Next d
    Next a
End Sub

Bitte testen.

Viel Erfolg,
wünscht Raoul

[Addi2020]

hat perfekt funktioniert  :05:

ich habe es so noch "probiert", aber der Erfolg war .. ok lassen wir das :20:

Code:

Sub Makro3()
Dim i As Long
    ' ActiveSheet.Range("$A$1:$AC$101656").AutoFilter Field:=14, Operator:= _
        xlFilterValues, Criteria2:=Array(0, "12/31/2001")
    'ActiveSheet.Range("$A$1:$AC$101656").AutoFilter Field:=15, Criteria1:= _
        "DB056B2"
    For i = 2 To Cells.SpecialCells(xlCellTypeLastCell).Row
      If Rows(i).Hidden = False Then
        Cells(i, 14).Select
        Selection.Cut
        Cells(i, 12).Select
        ActiveSheet.Paste
        Range(Cells(i, 15), Cells(i, 20)).Select
        Selection.Cut
        Cells(i, 14).Select
        ActiveSheet.Paste
        ActiveSheet.Range("$A$1:$AC$101656").AutoFilter Field:=14
        ActiveSheet.Range("$A$1:$AC$101656").AutoFilter Field:=15
        ActiveSheet.Range("$A$1:$AC$101656").AutoFilter Field:=14, Operator:= _
        xlFilterValues, Criteria2:=Array(0, "12/31/2001")
        ActiveSheet.Range("$A$1:$AC$101656").AutoFilter Field:=15, Criteria1:= _
        "DB056B2"
        Exit For
      End If
    'ActiveWorkbook.Save
  Next i
End Sub

---

Vielen Vielen.. vielen DANK Raoul