mittels x eintrag von einer Excel-Datei in andere schreiben, dabei filter deaktiviere

[markusf1895]

Hallo

will von einer Excel-Datei bei "X" in Spalte J die gesamte Zeile in andere Excel-Datei verfrachten.
Dies geht bisher schief wenn bei letzterer Excel Datei noch Filter gesetzt werden und ich bekomme es gerade nicht geregelt

Code:

Sub Worksheet_Change(ByVal Target As Excel.Range)
Const strZiel As String = "C:\Users\msobotta\Desktop\Bestellungen.xlsx"
'"H:\WORKGROUP\Chemie Tech-Support\PuplicGroup\Bestellungen\Bestellungen.xlsx"
'anpassen verzeichnis
Dim wsQuelle As Worksheet
Dim wsZiel As Worksheet
Dim readZeile As Long
Dim writeZeile As Long
Dim writeinto As Workbook
Dim tabellenseite As String

tabellenseite = "Bestellungen " & Range("A1").Value

   If Target.Column = 10 And (Target.Value = "X" Or Target.Value = "x") Then
       'MsgBox "Sie haben etwas in Spalte J verändert!"
       
       
       
       Set wsQuelle = ActiveSheet
       Set writeinto = Workbooks.Open(strZiel)
       Set wsZiel = writeinto.Worksheets(tabellenseite)
       
       For Each it In writeinto.Worksheets(tabellenseite).ListObjects  'mein Versuch
        it.ShowAllData
       Next                                                            'bis hier
        
        readZeile = Target.Cells.Row
       writeZeile = writeinto.Worksheets(tabellenseite).Cells(Rows.Count, "B").End(xlUp).Row + 1
     
       
       wsZiel.Cells(writeZeile, "B").Value = wsQuelle.Cells(readZeile, "A").Value
       wsZiel.Cells(writeZeile, "C").Value = wsQuelle.Cells(readZeile, "B").Value
       wsZiel.Cells(writeZeile, "D").Value = wsQuelle.Cells(readZeile, "C").Value
       wsZiel.Cells(writeZeile, "F").Value = wsQuelle.Cells(readZeile, "D").Value
       wsZiel.Cells(writeZeile, "G").Value = wsQuelle.Cells(readZeile, "E").Value
       wsZiel.Cells(writeZeile, "H").Value = wsQuelle.Cells(readZeile, "F").Value

       
       
       writeinto.Close savechanges:=True
   End If
   
   Set wsZiel = Nothing
   Set wsQuelle = Nothing
   Set writeinto = Nothing
End Sub

wäre euch sehr verbunden
viele Grüße
Markus

[Flotter Feger]

Hallo,

du musst prüfen, ob

.Filtermode = True

Erst dann kannst du ohne Fehler .ShowAllData aufrufen.

[markusf1895]

Code:

Sub Worksheet_Change(ByVal Target As Excel.Range)
Const strZiel As String = "C:\Users\msobotta\Desktop\Bestellungen.xlsx"
'"H:\WORKGROUP\Chemie Tech-Support\PuplicGroup\Bestellungen\Bestellungen.xlsx"
'anpassen verzeichnis
Dim wsQuelle As Worksheet
Dim wsZiel As Worksheet
Dim readZeile As Long
Dim writeZeile As Long
Dim writeinto As Workbook
Dim tabellenseite As String

tabellenseite = "Bestellungen " & Range("A1").Value

   If Target.Column = 10 And IsDate(Target.Value) = True Then
   '(Target.Value = "" Or Target.Value = " " Or Target.Value = "tilt") Then
   'Column anpassen
       'MsgBox "Sie haben etwas in Spalte J verändert!"
       
       
       
       Set wsQuelle = ActiveSheet
       Set writeinto = Workbooks.Open(strZiel)
       Set wsZiel = writeinto.Worksheets(tabellenseite)
       
       

       For Each it In writeinto.Worksheets(tabellenseite).ListObjects
       If it.FilterMode = True Then
       it.ShowAllData
       End If
       Next
     
       
       readZeile = Target.Cells.Row
       writeZeile = writeinto.Worksheets(tabellenseite).Cells(Rows.Count, "B").End(xlUp).Row + 1
     
       
       wsZiel.Cells(writeZeile, "B").Value = wsQuelle.Cells(readZeile, "A").Value
       wsZiel.Cells(writeZeile, "C").Value = wsQuelle.Cells(readZeile, "B").Value
       wsZiel.Cells(writeZeile, "D").Value = wsQuelle.Cells(readZeile, "C").Value
       wsZiel.Cells(writeZeile, "F").Value = wsQuelle.Cells(readZeile, "D").Value
       wsZiel.Cells(writeZeile, "G").Value = wsQuelle.Cells(readZeile, "E").Value
       wsZiel.Cells(writeZeile, "H").Value = wsQuelle.Cells(readZeile, "F").Value

       
       
       writeinto.Close savechanges:=True
       Rows(readZeile).Hidden = True
   End If
   
   Set wsZiel = Nothing
   Set wsQuelle = Nothing
   Set writeinto = Nothing
End Sub

habs so versucht, aber das beseitigt das Problem ebenfalls nicht

[Kuwer]

Hallo Markus,

es gibt keine (intelligenten) Tabellen im Blatt "Bestellungen 2018", sondern nur den normalen Autofilter. Ersetze diese it-Schleife durch folgendes:

        If wsZiel.AutoFilterMode Then
         If wsZiel.FilterMode Then
           wsZiel.ShowAllData
         End If
       End If

Gruß Uwe

[markusf1895]

Danke für eure Mühen, nur leider nach wie vor, das Problem bleibt.

Wenn ich in den Bestellungen beispielsweise nach Kevin filtere.
Dann einen Eintrag mittels Anfragenliste an die Bestellliste übermittelt,
wird der Eintrag, unter dem letzten Eintrag von Kevin, überschrieben.

Eigentlich hätte er die Filter entfernen sollen, dann die Zeile bestimmen, welche die letzte freie ist und es dort eintragen.
Sodass niemals andere Einträge überschrieben werden.


Hoffe Ihr könnt mir helfen

[Kuwer]

Hallo,

Danke für eure Mühen, nur leider nach wie vor, das Problem bleibt.

dann hattest Du meinen Tipp nicht umgesetzt!


Hier noch mal das komplette Makro:

Sub Worksheet_Change(ByVal Target As Excel.Range)
   Const strZiel As String = "C:\Users\msobotta\Desktop\Bestellungen.xlsx"
   '"H:\WORKGROUP\Chemie Tech-Support\PuplicGroup\Bestellungen\Bestellungen.xlsx"
   'anpassen verzeichnis
   Dim wsQuelle As Worksheet
   Dim wsZiel As Worksheet
   Dim readZeile As Long
   Dim writeZeile As Long
   Dim writeinto As Workbook
   Dim tabellenseite As String
   Dim it As ListObject

   If Target.Column = 10 And (Target.Value = "X" Or Target.Value = "x") Then
       'MsgBox "Sie haben etwas in Spalte J verändert!"
       tabellenseite = "Bestellungen " & Range("A1").Value
       Set wsQuelle = ActiveSheet
       Set writeinto = Workbooks.Open(strZiel)
       Set wsZiel = writeinto.Worksheets(tabellenseite)
       
       For Each it In wsZiel.ListObjects
         If it.AutoFilter.FilterMode Then
           it.AutoFilter.ShowAllData
         End If
       Next
       
       If wsZiel.AutoFilterMode Then
         If wsZiel.FilterMode Then
           wsZiel.ShowAllData
         End If
       End If
       
       readZeile = Target.Cells.Row
       writeZeile = writeinto.Worksheets(tabellenseite).Cells(Rows.Count, "B").End(xlUp).Row + 1
       wsZiel.Cells(writeZeile, "B").Value = wsQuelle.Cells(readZeile, "A").Value
       wsZiel.Cells(writeZeile, "C").Value = wsQuelle.Cells(readZeile, "B").Value
       wsZiel.Cells(writeZeile, "D").Value = wsQuelle.Cells(readZeile, "C").Value
       wsZiel.Cells(writeZeile, "F").Value = wsQuelle.Cells(readZeile, "D").Value
       wsZiel.Cells(writeZeile, "G").Value = wsQuelle.Cells(readZeile, "E").Value
       wsZiel.Cells(writeZeile, "H").Value = wsQuelle.Cells(readZeile, "F").Value
       writeinto.Close savechanges:=True
   End If
   
   Set wsZiel = Nothing
   Set wsQuelle = Nothing
   Set writeinto = Nothing
End Sub

Gruß Uwe

[markusf1895]

vielen Dank
entschuldige, keine Ahnung was ich zuvor verkackt hatte.