Kopieer rijen in nieuw bestand adhv ingevulde cel

sandra1978 · 7 okt 2019

Hallo,

Ik wil vanuit mijn uurrooster, een rooster genereren op basis van 1 welbepaalde gekozen lesgever (keuzelijst in cel a2). Ik dacht dit te doen met een for each lus, waarbij telkens gekeken wordt of de naam van de lesgever overeenkomt met degene die ingevuld is in cel a2, en zo telkens deze rij te kopiëren in een nieuw document.
Wanneer ik de huidige macro laat draaien, loopt excel echter vast.
Kan iemand me helpen?

Code:

Sub McrRoosterPerEenLesgever()


Dim i As Range


Set bronmapcopy = Workbooks("2019-2020 GrafischeHardeTechnieken_copy.xlsx") 'kopieer naar een nieuwe bestand
    
Set doelmap =  DoelMap = Workbooks.Add("O:\03_Harde_grafische_technieken_ambachten\4_Planning\1. Uurroosters\lesgever sjabloon.xltx") 'eender welk leeg document om te testen maakt niet uit
doelmap.saveas range.("a2").value
For Each i In bronmapcopy.Worksheets("rooster").Range("a5:a650")
        If i.Value = Range("a2").Value Then
        i.EntireRow.Copy DoelMap.Sheets("rooster").Range("a" & Sheets("rooster").Rows.Count).End(xlUp).Offset(1, 0)
        End If
    Next
    
       
End Sub

edmoor · 7 okt 2019

Je vergelijkt een Range object met de waarde van een cel.
Dat is uiteraard niet goed.

Daarnaast is de loop overbodig.
Je kan beter Range.Find gebruiken:
https://docs.microsoft.com/en-us/office/vba/api/excel.range.find

VenA · 7 okt 2019

Een .xlsx kan geen code bevatten. Je kan beter een filter gebruiken ipv zoeken en trage lusjes.

Code:

Sub VenA()
  With Sheets("rooster").Cells(4, 1).CurrentRegion
    c00 = .Parent.Cells(2, 1).Value
    .AutoFilter 1, c00
    .Copy Workbooks.Add.Sheets(1).Cells(1)
    With ActiveWorkbook
      .SaveAs ThisWorkbook.Path & "\" & c00 & Format(Now, "yyyymmdd hhmmss") & ".xlsx"
      .Close 0
    End With
    .AutoFilter
  End With
End Sub

Kopieer rijen in nieuw bestand adhv ingevulde cel

sandra1978

Gebruiker

Bijlagen

edmoor

Inventaris

VenA

Inventaris

Nieuwste berichten

Wij waarderen jouw privacy