Bepaalde waarde overkopieren naar andere sheet

[Vishal]

Hallo,

Ik zit met een brandende vraag, waar ik zelf niet uitkomt.

Situatie is als volgt:

Op tablad 1 heb ik een aantal waarden. Deze waarden wil ik overkopieren naar "nieuwe" tabbladen.

Voorbeeld: Alle waarden met "1." en de daarnaast liggende waarden wil ik naar een nieuwe tabblad kopieren. waarde "2." wil ik naar nieuwe tabblad.. etc etc.

Hebben jullie enig idee hoe ik dit het beste kan doen.

Ik stuur gelijk een voorbeeld met wat ik tot op heden heb.

Tot op heden heb ik dit als macro. Hierin selecteer ik al een range, maar de range varieert ook wel eens. De range moet bepaald worden aan de hand de waarden in kolom A.

Sub Zoek()
'
' Zoek Macro
'

'
    Range("A2:C7").Select
    Selection.Copy
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Paste
End Sub

nb. Om het nog moeilijker te maken. Voor elke indentieke waarde wil ik een nieuwe tabblad.. Als ik bv 10 indentieke waarden heb dan zou ik ook 10 tabbladen willen hebben.

Sorry mijn vraag wordt misschien te uitgebereid.

Hoop dat er een oplossing voor is.
Alvast super bedankt,

Groeten
Vishal

 

[spaarie]

Ik ben tot dit voor je gekomen...
Druk op "verdelen"

 

[Vishal]

Precies wat ik bedoel bedankt ervoor.

Bijkomend vraag, stel ik wijzig iets op blad 1. Dat zou ik dan weer willen herverdelen. De tabbladen zij al aanwezig. Is het mogelijk om dan allen de waarden over te zetten, ipv de tabbladen te verwijderen en opnieuw aan te maken?

Hartelijk dank alvast.

 

[Warme bakkertje]

Sub verdeel()
Dim uniekewaarden As New Collection, cel As Range, waarde As Variant
Application.ScreenUpdating = False
With Sheets("Blad1")
    On Error Resume Next
    For Each cel In .Range("A2:A" & .Range("A" & Rows.Count).End(xlUp).Row)
        uniekewaarden.Add cel.Value, CStr(cel.Value)
    Next cel
    On Error GoTo 0
    For Each waarde In uniekewaarden
        If Not Evaluate("isref(" & waarde & "!A1)") Then Sheets.Add.Name = waarde
        .Cells.AutoFilter field:=1, Criteria1:=waarde
        .Range("A1:C" & .Range("A" & Rows.Count).End(xlUp).Row).Copy
        With Sheets(waarde)
            .Paste: .Cells.EntireColumn.AutoFit
        End With
    Next waarde
    .ShowAllData: .AutoFilterMode = False
End With
For lCount = 1 To Sheets.Count
    For lCount2 = lCount To Sheets.Count
        If UCase(Sheets(lCount2).Name) < UCase(Sheets(lCount).Name) Then
            Sheets(lCount2).Move Before:=Sheets(lCount)
        End If
    Next lCount2
Next lCount
Application.ScreenUpdating = True
End Sub

 

[Vishal]

Rudi en Spaarie Hartelijk bedankt voor jullie hulp en delen van jullie kennis.
Top

groeten,
Vishal