Rijen in bepaalde tabblad zetten

[Evatar]

Ik heb een bestand met 1 tabblad met alle gegevens in. Deze gegevens wil ik opsplitsen in verschillende tabbladen door middel van een macro (zijn enkele duizenden lijnen). De macro zou zelf een nieuw tabblad aan moeten maken, een naam geven (de naam in kolom A in dit geval) en de gegevens in die tabbladen sorteren.

Heb in het bestand een paar gegevens gezet evenals het resultaat dat eruit zou moeten komen.

Bekijk bijlage Change to tabs.xlsx

Hulp word zeer op prijs gesteld (zelf zoek ik ook verder naar een oplossing)

Alvast bedankt.

 

[Evatar]

Ik heb ondertussen zelf nog wat gevonden maar heb nog wat hulp nodig voor het aanpassen van de code, hij sorteert niet echt, het aanmaken van de verschillende tabbladen lukt wel al alleen lukt het nog niet om de rijen te sorteren per tabblad.

Bekijk bijlage Change to tabs.xlsm

 

[VenA]

Volgens mij werkt jouw code niet echt of beter echt niet.

Je hebt een blad 'MD' Master Data? en dit wil je opsplitsen naar verschillende tabjes? Om te ondervangen of een tab al bestaat kan je een Functie gebruiken

Public Function Bladbestaat(s) As Boolean
Bladbestaat = False
For Each sh In Sheets
    If sh.Name = s Then
        Bladbestaat = True
        Exit Function
    End If
Next sh
End Function

Deze kan je dan aanroepen in een sub bv

Sub VenA()
Ar = Sheets("MD").Cells(1).CurrentRegion
For j = 1 To UBound(Ar)
    If Not Bladbestaat(Ar(j, 1)) Then
        Sheets.Add , Sheets(Sheets.Count)
        ActiveSheet.Name = Ar(j, 1)
    End If
    With Sheets(Ar(j, 1))
        .Cells(Application.CountA(.Columns(1)) + 1, 1).Resize(, 2) = Array(Ar(j, 1), Ar(j, 2))
    End With
Next j
End Sub

Welke sortering niet lukt en waar deze moet plaatsvinden staat er helaas niet bij. Dus kan ik geen antwoord op geven.

 

[Evatar]

ik heb de code ondertussen gevonden voor het bestand waarvoor het nodig was.

Dim blad As String, lr As Long
Application.ScreenUpdating = False
On Error Resume Next
lr = Sheets("MD").Range("H" & Rows.Count).End(xlUp).Row
For x = 2 To lr
at = 0
    blad = Sheets("MD").Range("H" & x).Value
    For Each sh In Sheets
        If sh.Name Like (blad) Then
           at = at + 1
        End If
   Next sh
If at = 0 Then
    Sheets.Add after:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = blad
    Sheets(Sheets.Count).Range("A1").Resize(1, 12).Value = Sheets("MD").Range("A1", "L1").Value
End If
Next x
For x = 2 To lr
    blad = Sheets("Input Data").Range("A" & x).Value
    Sheets("MD").Range("A" & x, "L" & x).Copy Destination:=Sheets(blad).Range("A" & Rows.Count).End(xlUp).Offset(1)
Next
Application.ScreenUpdating = True

Dim s$, r
Application.ScreenUpdating = False
With Sheets("MD").Range("A1").CurrentRegion
    .Parent.AutoFilterMode = False
    For Each r In .Offset(1).Resize(.Rows.Count - 1).Columns(8).Value
        If InStr(s, r) = 0 Then
            If Not Evaluate("ISREF('" & r & "'!A1)") Then
                Sheets.Add(after:=Sheets(Sheets.Count)).Name = r
            Else
                Sheets(r).UsedRange.ClearContents
            End If
            .AutoFilter 8, r ' 8 means column "H"
            .Copy Sheets(r).Range("A1")
            s = s & r
        End If
    Next
    .AutoFilter
End With: Application.ScreenUpdating = True

 

[snb]

@VenA

of het tabblad 'keurig' bestaat:

msgbox [isref(keurig!A1)]

 

[snb]

Ik zou het anders doen:

Private Sub CommandButton1_Click()
  Blad1.Columns(1).SpecialCells(2).AdvancedFilter 2, , Blad1.Cells(1, 20), True
  sn = Blad1.Columns(20).SpecialCells(2).Offset(1).SpecialCells(2)
  Blad1.Columns(20).SpecialCells(2).Offset(1).SpecialCells(2).ClearContents
  
  For Each it In sn
     If Not Evaluate("isref(" & it & "!A1)") Then Sheets.Add(, Sheets(Sheets.Count)).Name = it
     Blad1.Cells(2, 20) = it
     Blad1.Cells(1).CurrentRegion.AdvancedFilter 2, Blad1.Cells(1, 20).CurrentRegion, Sheets(it).Cells(1)
  Next
End Sub

 

[VenA]

ik heb de code ondertussen gevonden voor het bestand waarvoor het nodig was.

Volgens mij werkt deze code niet

@snb, Bedankt voor de isref. Kan de code weer wat ingekort worden.

Sub VenA()
ar = Sheets("MD").Cells(1).CurrentRegion
For j = 1 To UBound(ar)
    If Not Evaluate("isref(" & ar(j, 1) & "!A1)") Then Sheets.Add(, Sheets(Sheets.Count)).Name = ar(j, 1)
    With Sheets(ar(j, 1))
        .Cells(Application.CountA(.Columns(1)) + 1, 1).Resize(, 2) = Array(ar(j, 1), ar(j, 2))
    End With
Next j
End Sub

Nb.
Het lijkt overigens sneller te werken, op deze beperkte dataset, dan met AdvancedFilter. Zal wel weer een beetje <F8> trommelen worden om te bekijken wat AdvancedFilter exact doet.