Office: Gefilterte Zellen kopieren und in anderer Tabelle einfügen

Hallo zusammen
Ich möchte aus einer Tabelle "Preisliste" Zellen Filtern und in einer anderen Tabelle einfügen.
In der Tabelle habe ich Preisliste Arbeiten und Material. Gewählte Arbeiten ab E19 bis E202 soll in Tabelle "Annahme Formular" B16 und Gewähltes Material ab E205 bis E224 in B49 kopiert werden. Mein Makro funktioniert aber nur wenn die erste Position Markiert ist, wenn nicht dann fehlt fast alles. Hier mein Makro:
Sub EinfAnnahmeForm()
'
' EinfAnnahmeForm Makro
'

ActiveSheet.ListObjects("Tabelle4").Range.AutoFilter Field:=6, Criteria1:= _
"<>"
Range("E19").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Annahme Formular").Select
Range("B16").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Preisliste Arbeiten").Select
Range("E205").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Annahme Formular").Select
Range("B49").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("B95").Select
Application.CutCopyMode = False
End Sub
Hoffe Ihr könnt mir helfen..

 

Wenn Du XL2021 oder XL365 hast, ist =FILTER() Dein Freund. Dann brauchst Du den Cursor nicht wie einen Hund im Blatt Gassi zu führen (Spruch von Hajo).

 

Filter funktioniert nicht für meine Tabelle. hier noch eine Beispieldatei

 

Eher sowas wenn ich nach einem Wert Filtere, aber da fehlt mir die 2 Teile "Arbeiten" und "Material"

Sub AA()
'
' AA Makro
'
Sheets("Preisliste Arbeiten").Select
Tabelle4.Range("F19").AutoFilter 1, Tabelle4.Range("G1").Value
Tabelle1.UsedRange.SpecialCells(x1CellTypeVisible).Copy

End Sub

 

Hallo,

vielleicht erfüllt folgendes Makro deine Erwartungen:

Code:

Sub EinfAnnahmeForm()
   '
   ' EinfAnnahmeForm Makro
   '
   Dim WsQu As Worksheet, WsZl As Worksheet
  
   Set WsQu = Worksheets("Preisliste Arbeiten")
   Set WsZl = Worksheets("Annahme Formular")
  
   With WsQu
     .ListObjects("Tabelle4").Range.AutoFilter Field:=6, Criteria1:="<>"
     .Range("E19:H201").Copy
   End With
   WsZl.Range("B16").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
  
   WsQu.Range("E205:H224").Copy
   WsZl.Range("B49").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
  
   WsQu.ListObjects("Tabelle4").Range.AutoFilter Field:=6
  
   Range("B95").Select
   Application.CutCopyMode = False
End Sub

 

Hallo,

und hier ist die etwas flexiblere Variante. Sie sucht in der Tabellenspalte "Beschreibung" nach dem ersten Auftreten des Wortes "Material" und ermittelt so die beiden Bereiche fürs Copy/PasteSpecial.

Code:

Sub EinfAnnahmeForm()
   '
   ' EinfAnnahmeForm Makro
   '
   Dim WsQu As Worksheet, WsZl As Worksheet
   Dim ZlMat As Long, ZlHdr As Long, ZlTab As Long, ZlArb As Long
  
   Set WsQu = Worksheets("Preisliste Arbeiten")
   Set WsZl = Worksheets("Annahme Formular")
  
   With WsQu.ListObjects("Tabelle4")
  
      ZlHdr = .HeaderRowRange.Row
      ZlMat = .ListColumns("Beschreibung").DataBodyRange.Find(What:="Material", LookIn:=xlValues, LookAt:=xlWhole).Row
      ZlTab = .ListRows.Count
      ZlArb = ZlMat - ZlHdr
  
      .Range.AutoFilter Field:=6, Criteria1:="<>"
  
      With .ListColumns("Menge").DataBodyRange
    
           .Resize(ZlArb - 2, 4).Copy
           WsZl.Range("B16").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
  
           .Offset(ZlArb + 1, 0).Resize(ZlTab - ZlArb - 1, 4).Copy
           WsZl.Range("B49").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
          
      End With
  
     .Range.AutoFilter Field:=6
  
   End With
  
   Range("B95").Select
   Application.CutCopyMode = False
  
End Sub

 

In Schweizerdeutsch würde ich jetzt sagen: "Geile Siech!" Was so viel heisst wie Super Typ oder Du bist ein Held..
Danke dir sehr! Es funktioniert einwandfrei! (Habe Version 2 genommen)
Gruss Jürg

 

Hallo liebe Helfer
Noch eine Frage zur gleichen Tabelle:
Ich möchte mit einem Makro die Werte aus dem "AnnahmeFormular" Arbeiten (A17:E45) kopieren (also nur die gefilterten Zellen) und in die Tabelle "Offene Zahlungen Arbeiten" einfügen aber nur Werte ohne Formeln (Erste Spalte ist ein Formelwert) und so dass es die vorhanden Einträge nicht überschreibt sondern nach unten schiebt.
Das gleiche dann mit Material ( A50:E87) in "Offene Zahlungen Material". Wenn Kein Material oder Arbeiten soll es einfach den Text "Keine ...Kosten.." einfügen (steht schon in Tabelle wenn kein Wert-nur kopieren)
Ich finde einfach den richtigen VBA Code nicht ohne dass es mir in der Zieltabelle bestehende Einträge überschreibt..
Kann mir jemanden helfen?
Grüsse Jürg