Opdele ét ark i flere ark

Jeg spurgte Copilot, og de viste denne VBA-kode:
Sub SplitBySupplier()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim supplierCol As String
    Dim supplierRange As Range
    Dim supplierName As Variant
    Dim uniqueSuppliers As Object
   
    ' Indstil det aktive ark
    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

    ' Kolonne hvor leverandørnavne/-numre befinder sig
    supplierCol = "B" ' Ændre til den korrekte kolonnebogstav
 
    ' Indsæt leverandørnavne i en Collection
    Set uniqueSuppliers = CreateObject("Scripting.Dictionary")
    For Each supplierName In ws.Range(supplierCol & "2:" & supplierCol & lastRow)
        If Not uniqueSuppliers.exists(supplierName.Value) Then
            uniqueSuppliers.Add supplierName.Value, Nothing
        End If
    Next supplierName

    ' Opret et ark for hver leverandør og kopier data
    For Each supplierName In uniqueSuppliers.Keys
        Dim newSheet As Worksheet
        Set newSheet = Worksheets.Add
        newSheet.Name = supplierName
        ws.Rows(1).Copy Destination:=newSheet.Rows(1) ' Kopier overskrifter
       
        Dim i As Long
        For i = 2 To lastRow
            If ws.Cells(i, supplierCol).Value = supplierName Then
                ws.Rows(i).Copy Destination:=newSheet.Rows(newSheet.Rows.Count).End(xlUp).Offset(1, 0)
            End If
        Next i
    Next supplierName
End Sub

Ved ikke, om det virker 😉

Hvis ingen melder sig på banen, skal jeg kigge på en VBA løsning. Men jeg er først tilbage, omkring middagstid.
Det er ikke noget problem at lave en sådan løsning.

Det kan gøres meget nemt på følgende måde, der virker,

Slet kolonner der er blanke (B, C, D og F)
Opret en pivottabel
Material Description under Row field
Supplier under Filters
Tryk på Options og tryk på Show Filter Report Pages
Tryk på OK.

#1 - hvis ikke du ved om det du foreslår virker, hvofor så fylde tråden med noget.
Test det inden!

#1 Det virker ikke, men det er muligvis pga min manglende VBA-viden. Jeg ved i hvert fald ikke, hvad der skal rettes på den linje der fejler

#2 En pivot løser ikke opgaven, når jeg skal bruge et separat ark pr. leverandør

#3 Jeg venter meget gerne på din løsning. Du plejer at være super god til at hjælpe mig😊

#5
Du skriver:
#2 En pivot løser ikke opgaven, når jeg skal bruge et separat ark pr. leverandør

Du har ikke ret i, at en pivot ikke løser opgaven. Det er præcist hvad den foreslåede løsning gør. Har du overhovedet prøvet det foreslåede?

#6 Du har ret i at der bliver kreeret et ark pr leverandør. Det var mig, der ikke havde fået den sidste "feature" med.

Men når jeg gør det, så er der stadig filter på de enkelte faner, som kan foldes ud, så man kan se alle data. Og disse må ikke være tilgængelige - kun de varer, der vedrører den enkelte leverandør

Oprindelig skrev du:

Jeg har behov for at kunne opdele denne liste pr. leverandør - altså ét ark pr. leverandør.

Du skrev ikke noget om det, du nu stiller som et krav.

#4 Du har ret, og jeg har nu testet en løsning, der virker. Inden kørsel skal Ark1 omdøbes til Master:
Sub SplitDataBySupplierWithTables()
    Dim wsMaster As Worksheet
    Dim wsNew As Worksheet
    Dim lastRow As Long
    Dim supplierCol As Long: supplierCol = 8 ' Kolonne H
    Dim dict As Object
    Dim key As Variant
    Dim r As Long
    Dim tblRange As Range
    Dim tblName As String
    Dim headerRow As Range
    Dim destRow As Long
    Dim supplierName As String
    Dim safeSheetName As String

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Set dict = CreateObject("Scripting.Dictionary")
    Set wsMaster = ThisWorkbook.Sheets("Master") ' Tilpas hvis nødvendigt
    lastRow = wsMaster.Cells(wsMaster.Rows.Count, supplierCol).End(xlUp).Row

    ' Find alle unikke leverandører i kolonne H
    For r = 2 To lastRow
        supplierName = Trim(wsMaster.Cells(r, supplierCol).Value)
        If supplierName <> "" Then
            If Not dict.exists(supplierName) Then
                dict.Add supplierName, Nothing
            End If
        End If
    Next r

    ' Gennemgå hver leverandør og opret nyt ark
    For Each key In dict.Keys
    ' Lav et sikkert ark-navn (max 31 tegn og uden ulovlige tegn)
    safeSheetName = Left(CleanSheetName(CStr(key)), 31)

       
        ' Slet arket hvis det allerede findes
        On Error Resume Next
        Application.DisplayAlerts = False
        ThisWorkbook.Sheets(safeSheetName).Delete
        Application.DisplayAlerts = True
        On Error GoTo 0
       
        ' Opret nyt ark
        Set wsNew = ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))
        wsNew.Name = safeSheetName
       
        ' Kopier overskrifter
        Set headerRow = wsMaster.Rows(1)
        headerRow.Copy Destination:=wsNew.Range("A1")
       
        ' Kopier rækker for leverandøren
        destRow = 2
        For r = 2 To lastRow
            If Trim(wsMaster.Cells(r, supplierCol).Value) = key Then
                wsMaster.Rows(r).Copy Destination:=wsNew.Rows(destRow)
                destRow = destRow + 1
            End If
        Next r
       
        ' Opret tabel
        Set tblRange = wsNew.Range("A1").CurrentRegion
        tblName = "Tbl_" & Replace(safeSheetName, " ", "_")
        On Error Resume Next
        wsNew.ListObjects.Add(xlSrcRange, tblRange, , xlYes).Name = tblName
        On Error GoTo 0
    Next key

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

    MsgBox "Vareliste er nu opdelt i " & dict.Count & " ark med formaterede tabeller.", vbInformation
End Sub

' Funktion til at rense ark-navne
Function CleanSheetName(s As String) As String
    Dim chars As Variant: chars = Array("/", "\", "?", "*", "[", "]", ":", "'", """")
    Dim i As Integer
    For i = LBound(chars) To UBound(chars)
        s = Replace(s, chars(i), "_")
    Next i
    CleanSheetName = Application.WorksheetFunction.Trim(s)
End Function

#4: Det burde helt forbydes, at give AI løsninger !

#10 - ja, men hvem skal håndtere det ? jeg foreslog på et tidspunkt at lave det sådan, at bidrag fra AI løsninger skulle mærkes. Men der kom aldrig respons fra folkene bag Eksperten.dk

i sidste ende, så bliver det stille og roligt, afviklingen af Eksperten.dk