Automatisches Filtern & Kopieren von Zeilen

Philip1306 · 2023-09-18T13:21:39+00:00

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

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

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

Automatisches Filtern & Kopieren von Zeilen

Forumthread: Automatisches Filtern & Kopieren von Zeilen

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Automatisches Filtern & Kopieren von Zeilen

Forumthread: Automatisches Filtern & Kopieren von Zeilen

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

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread