Live-Forum - Die aktuellen Beiträge
Datum
Titel
07.05.2024 21:30:42
Bilder aus URL in Zelle einfügen - Code anpassen
07.05.2024 20:36:09
xverweis / name Funktion
07.05.2024 20:10:42
Datum z.B. 1897 wird nicht als Datum angezeigt
07.05.2024 19:47:07
Excel Lohnabrechnung anhand 2 Suchkriterien
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1944to1948
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1944to1948
1944to1948
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Automatisches Filtern & Kopieren von Zeilen

Automatisches Filtern & Kopieren von Zeilen
18.09.2023 13:21:39
Philip1306
Hallo!
Ich habe folgende Herausforderung:

Ich bekomme eine Datei mit verschiedenen Lieferanten, die verschiedene Artikel liefern. Aus dieser Datei möchte ich nun für jeden Lieferanten ein Tabellenblatt (Lieferant A, B, C) erzeugen, die zum Lieferanten zugehörigen Zeilen sollen in das Tabellenblatt kopiert werden und dann aus den Tabellenblättern ein je eine PDF erstellt werden.

Leider bin ich in VBA nicht so bewandert dies zu lösen und hoffe auf euer Fachwissen.

https://www.herber.de/bbs/user/162941.xlsx

Vielen Dank

13
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: dazu braucht es auch kein VBA ...
18.09.2023 14:24:21
neopa C
Hallo Philipp,

... das wäre z.B. mit Formel(n) möglich. In Deiner Version mit FILTERN() oder ganz ohne Formeln mit PowerQuery (mehr dazu sieh z.B. mal hier:
https://excelhero.de/power-query/power-query-ganz-einfach-erklaert/

In beigefügter Datei https://www.herber.de/bbs/user/162942.xlsx ist das für Deine Beispieldatei realisiert. Für andere Lieferanten-Namen müßtest Du nur den Filter in den drei Abfragen ändern.

Gruß Werner
.. , - ...
Anzeige
AW: dazu braucht es auch kein VBA ...
18.09.2023 14:33:04
Philip1306
Hallo Werner, vielen Dank für die Lösung.

Bei 3 Lieferanten mag das super funktionieren, aber wie ist es mit über 100 Lieferanten/Tabellenblättern?
AW: nachgefragt ...
18.09.2023 15:25:08
neopa C
Hallo Philipp,

... sind es immer die gleichen Lieferanten oder verschiedene? Aus welchem Grund überhaupt für jedes ein eigenes Tabellenblatt? Mit der Standard-Filterung kann man drei Mausklicks die Daten für jeden Lieferanten sich schnell anzeigen lassen. Wenn Du aber für jeden Lieferanten einen separaten Ausdruck benötigst, dann brauchst Du auch keine getrennten Blätter. Dann wäre wohl eine VBA-Lösung am sinnvollsten. Allerdings halte ich mich aus VBA prinzipiell heraus, solltest Du diese benötigen.

Gruß Werner
.. , - ...
Anzeige
AW: nachgefragt ...
18.09.2023 15:28:57
Philip1306
Hallo Werner,
interessanter Ansatz den Ausdruck per VBA direkt aus dem Gesamttabellenblatt heraus zu machen.
Grundsätzlich sind es immer die gleichen Lieferanten.
Ich möchte die einzelnen Tabellenblätter je Lieferant dann in ein PDF umwandeln und an den Lieferanten als Bestellung versenden.
AW: nachgefragt ...
18.09.2023 16:45:39
Alwin Weisangler
Hallo Philipp,

mit VBA wäre es so: 


Option Explicit



Sub NachLieferantenTrennen()

    Dim objDict As Object: Set objDict = CreateObject("Scripting.Dictionary")

    Dim wks As Worksheet

    Dim i&, j&, k&, r&, arrLieferant(), arrTmp(1 To 10000, 1 To 10), arrTab(), tblNamen$

    With Tabelle1

        For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row

            objDict(.Cells(i, 2).Text) = 0

        Next i

    End With

    arrLieferant = objDict.keys

    For Each wks In ThisWorkbook.Worksheets

        tblNamen = tblNamen & wks.Name & "~"

    Next

    Tabelle1.Range("A1:J1").Copy

    For i = 1 To objDict.Count

        If InStr(1, tblNamen, arrLieferant(i - 1)) = 0 Then

            Sheets.Add After:=Sheets(Sheets.Count)

            With ActiveSheet

                .Name = arrLieferant(i - 1)

                .Range("A1").PasteSpecial xlAll

                .Columns("A:J").ColumnWidth = 10.71

            End With

        End If

    Next i

    With Tabelle1

        For i = 0 To UBound(arrLieferant)

            For j = 2 To .Cells(Rows.Count, 1).End(xlUp).Row

                If arrLieferant(i) = .Cells(j, 2) Then

                    r = r + 1

                    For k = 1 To 10

                        arrTmp(r, k) = .Cells(j, k)

                    Next k

                End If

            Next j

            arrTab = Application.Transpose(arrTmp)

            ReDim Preserve arrTab(1 To UBound(arrTab), 1 To r)

            arrTab = Application.Transpose(arrTab)

            With Sheets(arrLieferant(i))

                .Range("A2:J" & .Cells(Rows.Count, 1).End(xlUp).Row + 1).ClearContents

                .Cells(2, 1).Resize(UBound(arrTab, 1), UBound(arrTab, 2)) = arrTab

            End With

            r = 0

        Next i

    End With

End Sub

Wenn ein Lieferant dazukommt wird auch das Tabellenblatt + Name des Lieferanten mit erzeugt.

Gruß Uwe
Anzeige
AW: nachgefragt ...
18.09.2023 16:50:19
Alwin Weisangler
kleiner Nachtrag: 



Set objDict = Nothing

ans Ende (vor End Sub) der Prozedur eintragen.
AW: nachgefragt ...
18.09.2023 16:59:21
Philip1306
Hallo Alwin!
Das funktioniert richtig richtig gut. Einfach mega! Vielen Dank dafür!

Das Skript läuft an dieser Stelle auf einen Fehler und es wird das letzte Tabellenblatt ohne Inhalt erstellt.

.Cells(2, 1).Resize(UBound(arrTab, 1), UBound(arrTab, 2)) = arrTab

Hast du dafür auch eine Lösung?
AW: nachgefragt ...
18.09.2023 17:52:24
Alwin Weisangler
da wird wohl das Array leer sein oder das Tabellenblatt ist schreibgeschützt.
öffne das Localfenster --> löse die Prozedur aus. Dann bleibt die Prozedur beim Fehler stehen.
suche im Lokalfenster die Zählvariable i und schau nach deren Nummer.
Setze vor dieser Zeile ein Stop --> drücke F5 so lange bis eine Nummer vor dem Fehler erreicht ist.
Dann mit F8 Step by step bis vor dem Fehler.
Dann suchst du im Localfenster nach arrTab und schaust ob in dem Array Zellen mit Werten zu finden sind.
Sind Werte drin ist das Tabellenblatt schreibgeschützt.

Gruß Uwe
Anzeige
AW: nachgefragt ...
19.09.2023 09:51:29
Philip1306
Guten Morgen Uwe,

ich bin deinen Anweisungen gefolgt, musste feststellen, dass für den Lieferanten Werte enthalten sind und das Tabellenblatt ist nicht schreibgeschützt.
Die Folge ist, dass nicht alle Tabellenblätter korrekt befüllt werden :-(

Ich habe weitere Makros erstellt:
a) Seite einrichten
Habe ich mit dem Rekorder aufgezeichnet - hier habe ich das Problem, dass sobald weitere Lieferanten hinzukommen, diese nicht im Makro enthalten sind.
Ich bekomme es leider nicht hin den Code so anzupassen, dass er alle erstellten Tabellenblätter in Querformat auf einer Seite einrichtet

b) Drucken in pdf
Das habe ich hinbekommen und funktioniert sehr gut, aber auch hier würde ich mir wünschen, dass das Makro automatisch alle Tabellenblätter markiert und dann den Druck startet

Ich wäre dir sehr verbunden, wenn du mir hierbei nochmal helfen könntest.
Anzeige
AW: nachgefragt ...
19.09.2023 16:29:22
Alwin Weisangler
Wir gehen der Reihe nach.

- hast du dir den Inhalt des Arrays (wo der Fehler passiert) angeschaut und die sind Werte drin?

- Tritt der Fehler beim Schreiben in ein schon länger existierendes Tabellenblatt auf.
- Wenn ja Lösche dieses Tabellenblatt und starte einen weiteren Durchlauf meiner Prozedur. Dabei wird das Tabellenblatt neu erzeugt.

Tritt eine Fehlermeldung "unzulässiger Name" auf gibt es Zeichen (z.B. / \ ?) im Firmennamen, welche nicht für Tabellenblattnamen zugelassen sind.
2 Möglichkeiten Entweder den Namen ändern via Wert=Replace(Wert,"\","") oder du passt den Namen der Firma in der entsprechenden Zelle an.

Die anderen Fragen anzugehen macht erst Sinn, wenn die Ursache für den Fehler beseitigt ist. An der Prozedur liegt es definitiv nicht.

Gruß Uwe

Anzeige
AW: nachgefragt ...
19.09.2023 20:04:23
Philip1306
Hallo Uwe,

ich habe den Fehler gefunden. Es kommt vor, dass ein Lieferant nur einen Artikel liefern soll. Demzufolge liegt nur eine belegte Zeile vor...

Kannst du mir sagen welche Parameter angepasst werden müssen?
Danke dir.
AW: nachgefragt ...
19.09.2023 22:08:36
Alwin Weisangler
ja, durch das Transponieren wird bei einer Zeile eben aus einem 2 dim. Array ein 1 dim. Array. Da muss die Übergabe natürlich anders sein.
angepasst so: 


Option Explicit



Sub NachLieferantenTrennen()

    Dim objDict As Object: Set objDict = CreateObject("Scripting.Dictionary")

    Dim wks As Worksheet

    Dim i&, j&, k&, r&, arrLieferant(), arrTmp(1 To 10000, 1 To 10), arrTab(), tblNamen$

    With Tabelle1

        For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row

            objDict(.Cells(i, 2).Text) = 0

        Next i

    End With

    arrLieferant = objDict.keys

    For Each wks In ThisWorkbook.Worksheets

        tblNamen = tblNamen & wks.Name & "~"

    Next

    Tabelle1.Range("A1:J1").Copy

    For i = 1 To objDict.Count

        If InStr(1, tblNamen, arrLieferant(i - 1)) = 0 Then

            Sheets.Add After:=Sheets(Sheets.Count)

            With ActiveSheet

                .Name = arrLieferant(i - 1)

                .Range("A1").PasteSpecial xlAll

                .Columns("A:J").ColumnWidth = 10.71

            End With

        End If

    Next i

    With Tabelle1

        For i = 0 To UBound(arrLieferant)

            For j = 2 To .Cells(Rows.Count, 1).End(xlUp).Row

                If arrLieferant(i) = .Cells(j, 2) Then

                    r = r + 1

                    For k = 1 To 10

                        arrTmp(r, k) = .Cells(j, k)

                    Next k

                End If

            Next j

            arrTab = Application.Transpose(arrTmp)

            ReDim Preserve arrTab(1 To UBound(arrTab), 1 To r)

            arrTab = Application.Transpose(arrTab)

            With Sheets(arrLieferant(i))

                .Range("A2:J" & .Cells(Rows.Count, 1).End(xlUp).Row + 1).ClearContents

                If r = 1 Then

                    For j = 1 To UBound(arrTab)

                        .Cells(2, j) = arrTab(j)

                    Next j

                Else

                    .Cells(2, 1).Resize(UBound(arrTab, 1), UBound(arrTab, 2)) = arrTab

                End If

            End With

            r = 0

        Next i

    End With

    Set objDict = Nothing

End Sub


Gruß Uwe

Anzeige
AW: nachgefragt ...
21.09.2023 12:12:20
Philip1306
Hallo Uwe,

vielen Dank für die Anpassungen - das funktioniert hervorragend! Vielen Dank nochmals dafür!
Die anderen Anforderungen habe ich glücklicherweise selbst gelöst bekommen.

Links zu Excel-Dialogen

Frame

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige