Range gegevens selecteren kopiëren naar een tabblad gelijk aan waarde in cel.

[inMilu]

Beste allen,

Waar ik soms wel eens speel met VB, schiet mijn kennis momenteel te kort voor een functionaliteit die ik graag zou willen.
Zal het uitleggen met behulp van onderstaande afbeelding.

In kolom A staan 200+ Chassisnummers, elk chassisnummer heeft bepaalde informatie dat wordt weergegeven in kolom B t/m V.
Nu moeten deze informatie in een apart tabblad gezet worden per chassis nummer. Nu is het mij middels een macro al gelukt om van alle waardes in kolom A een gelijknamig tabblad te maken, dat scheelt weer met het aanmaken ervan!

Wat ik me nu graag zou willen, mits mogelijk uiteraard, is een macro die deze gegevens in de corresponderende tabblad zet. Dat hij automatisch de range selecteert, bijvoorbeeld A8:V39, dan tabblad selecteren gelijk aan de waarde in kolom A (A8) en daar dan plakt.

Dus in normale woorden:
Begin bij A8, ga tot de volgende waarde in kolom A en dan -1.
Breid de selectie uit tot kolom V.
Kopieer selectie.
Ga naar sheet gelijk aan waarde in kolom A ( in alle cellen in A kan maar 1 waarde staan ).
Selectie plakken.
Terug naar Blad 1.


En dit dan per waarde in kolom A, zo'n 200+ keer.

Is er iemand die mij hiermee kan helpen? Mocht ik onduidelijk zijn in de vraagstelling dan probeer ik dit te verduidelijken.

B.v.d.!

 

[inMilu]

Geen bump.

 

[Cobbe]

Bumpen is verboden.
Trouwens dit is niet de fotoclub hier!

 

[inMilu]

De fotoclub?

 

[abevleeming]

Hij bedoelt dat een voorbeeldbestand veel handiger is dan een foto. Om nu een oplossing voor je te verzinnen moeten we eerst dit blad na gaan lopen bouwen. De meeste oplossingen worden gegeven nadat de "verlosser" eerst zelf een tijdje heeft lopen friemelen om te kijken of de oplossing ook echt werkt of juist valkuilen heeft.

 

[inMilu]

Bekijk bijlage VoorbeeldBestand_Excelforum.xlsxBekijk bijlage VoorbeeldBestand_Excelforum.xlsx

Hij bedoelt dat een voorbeeldbestand veel handiger is dan een foto. Om nu een oplossing voor je te verzinnen moeten we eerst dit blad na gaan lopen bouwen. De meeste oplossingen worden gegeven nadat de "verlosser" eerst zelf een tijdje heeft lopen friemelen om te kijken of de oplossing ook echt werkt of juist valkuilen heeft.

Bedankt voor je uitleg. Ik zal het bestand aanpassen, gezien er bedrijfsgevoelige informatie in staat momenteel ( vandaar ook de blur ) koos ik voor een foto, en deze toevoegen.

 

[Cobbe]

Verwijder alle bladen behalve Blad1, draai dan deze macro eens:

Sub cobbe()
With Sheets("Blad1")
 For Each cl In .Range("A8:A105").SpecialCells(xlCellTypeConstants)
  bladnaam = Str(cl)
   begin = cl.Row
    For e = cl.Row + 1 To cl.Row + 100
     If .Cells(e, 1) <> "" Then einde = e - 1: Exit For
    Next
    For i = 1 To Worksheets.Count
     If Worksheets(i).Name = bladnaam Then
        exists = True
     End If
    Next i
    If Not exists Then
     Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = bladnaam
    End If
     .Range("A" & begin & ":Z" & einde).Copy Sheets(bladnaam).Range("A" & Sheets(bladnaam).UsedRange.Row + 1)
       Sheets(bladnaam).Columns.AutoFit
 Next
End With
End Sub

Moet nog iets aan gebeuren maar dat komt dan wel achteraan.

 

[inMilu]

Hey Cobbe,

Allereerst bedankt voor de hulp! De macro werkt inderdaad tot aan A105. Had het eens geprobeerd tot einde blad, maar dan crashed Excel haha. Handmatig de range even verzetten en macro opnieuw runnen lijkt me het handigste dan, niet?

Dan vroeg ik me ook nog af of het mogelijk is rij 7 overal mee te nemen, dit was ik vergeten te vermelden. Dit zijn de titels die ik graag ook boven de data in de tabbladen zou willen hebben.

Nogmaals bedankt!

 

[Cobbe]

Met deze kleine aanpassing wordt ook regel 7 meegenomen:

Sub cobbe()
With Sheets("Blad1")
 For Each cl In .Range("A8:A105").SpecialCells(xlCellTypeConstants)
  bladnaam = Str(cl)
   begin = cl.Row
    For e = cl.Row + 1 To cl.Row + 100
     If .Cells(e, 1) <> "" Then einde = e - 1: Exit For
    Next
    For i = 1 To Worksheets.Count
     If Worksheets(i).Name = bladnaam Then
        exists = True
     End If
    Next i
    If Not exists Then
     Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = bladnaam
    End If
     .Range("A7:Z7").Copy Sheets(bladnaam).Range("A1")
     .Range("A" & begin & ":Z" & einde).Copy Sheets(bladnaam).Range("A" & Sheets(bladnaam).UsedRange.Row + 1)
       Sheets(bladnaam).Columns.AutoFit
 Next
End With
End Sub

 

[inMilu]

Thanks! Raad je aan de range in de macro steeds aan te passen, en opnieuw te runnen? Of is er een mogelijkheid het hele blad te laten werken zonder Excel te crashen?

 

[Cobbe]

Even wachten op specialisten ter zake,
ik weet niet direct waarom het vastloopt bij doorlopen van het hele bereik.

 

[inMilu]

Super, wacht ik daar even op! Anders ga ik handmatig de range verzetten. Bedankt iig!

 

[Cobbe]

Heb de code aangepast zodat hij wel het hele bereik doorloopt zonder haperen:

Sub cobbe()
' eerst alle bladen verwijderen behalve Blad1
Application.DisplayAlerts = False
 For i = Worksheets.Count To 1 Step -1
     If Worksheets(i).Name <> "Blad1" Then
         Worksheets(i).Delete
     End If
 Next i
Application.DisplayAlerts = True
Dim cl As Variant
With Sheets("Blad1")
 For Each cl In .Range("A8:A10000").SpecialCells(xlCellTypeConstants)
  bladnaam = cl
   begin = cl.Row
    For e = cl.Row + 1 To cl.Row + 500
     If .Cells(e, 1) <> "" Then einde = e - 1: Exit For
    Next
    For i = 1 To Worksheets.Count
     If Worksheets(i).Name = bladnaam Then
        exists = True
     End If
    Next i
    If Not exists Then
     Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = bladnaam
    End If
     .Range("A7:Z7").Copy Sheets(bladnaam).Range("A1")
     .Range("A" & begin & ":Z" & einde).Copy Sheets(bladnaam).Range("A" & Sheets(bladnaam).UsedRange.Row + 1)
       Sheets(bladnaam).Columns.AutoFit
 Next
End With
End Sub

 

[inMilu]

Hoi Cobbe,

Wanneer ik je macro run, krijg ik de fout: Fout 9, Subscript valt buiten het gebruik.

Hij maakt dan het 1e tabblad wel aan, maar hier staan geen gegevens in en dan stopt de macro. Enig idee?

 

[Cobbe]

Kan je hier mee leven?

Sub cobbe()
' eerst alle bladen verwijderen behalve Blad1
Application.DisplayAlerts = False
 For i = Worksheets.Count To 1 Step -1
     If Worksheets(i).Name <> "Blad1" Then
         Worksheets(i).Delete
     End If
 Next i
Application.DisplayAlerts = True
Dim cl As Variant
With Sheets("Blad1")
 For Each cl In .Range("A8:A10000").SpecialCells(xlCellTypeConstants)
  bladnaam = cl
   begin = cl.Row
    For e = cl.Row + 1 To cl.Row + 500
     If .Cells(e, 1) <> "" Then einde = e - 1: Exit For
    Next
    For i = 1 To Worksheets.Count
     bladnaam = "CH" & cl
      If Worksheets(i).Name = bladnaam Then
        exists = True
      End If
    Next i
    If Not exists Then
     Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = bladnaam
    End If
     .Range("A7:Z7").Copy Sheets(bladnaam).Range("A1")
     .Range("A" & begin & ":Z" & einde).Copy Sheets(bladnaam).Range("A" & Sheets(bladnaam).UsedRange.Row + 1)
       Sheets(bladnaam).Columns.AutoFit
 Next
End With
End Sub

 

[inMilu]

Super! Werkt perfect, enorm bedankt!