for loop loopt vast: foutcode 1004 'door de toepassing of object

Status
Niet open voor verdere reacties.
S

sandra1978

Gebruiker
Lid geworden
21 feb 2011
Berichten
64
Hallo,

Mijn VBA-code doet het volgende: (het gaat enkel over macro mcrmixlokalen)

- met for loop nakijken in kolom K of er cellen zijn die dezelfde waarde hebben als een cel uit de lijst van tabblad bereiken, kolom P. (Een for each, binnen een for loop)
- indien de waarde hetzelfde is, wordt de hele rij van kolom K, onderaan gekopieerd, de waarde in cel K wordt aangepast, naar de waarde die naast kolom P staat van het tabblad bereiken.
--> concreter: als het lokaal 1015A wordt teruggevonden, wordt deze lijn gekopieerd, en in de kolom K wordt de waarde 1015 ingevuld, dan wordt er nog een lijn gekopieerd, en wordt de waarde 2018 ingevuld. Stel dat er bij het tabblad bereiken nog een kolom is ingevuld, dan wordt er nog een lijn gekopieerd.

Deze code werkt.... traag soms, maar ze werkt.

Tot we opeens lijn 16467 kopiëren (dan zitten we al op lijn 36464 te kopiëren), dan zit het vast en krijg ik de foutmelding:
1004: door de toepassing of object gedefineerde fout'

Ik heb al getest om enkele 100-en lijnen over te slaan en verder te beginnen, maar nee, ik krijg dezelfde foutmelding. Ik kan er totaal niet aan uit.
Please help!

Code: 
Sub McrMixLokalen()

 Dim brongegevens As Worksheet
 Set brongegevens = ActiveSheet
 Dim iLastRow As Long
 Dim i As Long
 iLastRow = Worksheets("brongegevens").Cells(Rows.Count, "k").End(xlUp).row
 
 Dim mixlokaal As Variant
 Dim lastrowlokaal As Long
 lastrowlokaal = Worksheets("bereiken").Range("p2").End(xlDown).row
 
 
 With Application
    .EnableEvents = False
    .ScreenUpdating = False
    .DisplayAlerts = False
 
 'kolom K van brongegevens: voor elke lijn nakijken of er een lokaal in staat dat in de lijst staat van mixlokalen. Indien zo: onderaan nieuwe rij toevoegen,
 '15/9/2020: aangepast: in plaats van copy/paste: row.value = row.value, veel sneller
 
 For i = 3 To iLastRow
 For Each mixlokaal In Worksheets("bereiken").Range("p2", "p" & lastrowlokaal)
 
 
 If Cells(i, "k").Value = mixlokaal.Value Then
 'elke keer opnieuw laatste rij definiëren, anders wordt dit telkens overschreven
 Dim ilastrow2 As Long
 ilastrow2 = Worksheets("brongegevens").Cells(Rows.Count, "k").End(xlUp).row
 Rows(ilastrow2 + 1).Value = Rows(i).Value
 j = ilastrow2 + 1
 Cells(j, "K").Value = mixlokaal.Offset(0, 1).Value
 
 If mixlokaal.Offset(0, 2).Value <> "" Then
 Rows(ilastrow2 + 2).Value = Rows(i).Value
 j = ilastrow2 + 2
 Cells(j, "K").Value = mixlokaal.Offset(0, 2).Value
 End If
 
 If mixlokaal.Offset(0, 3).Value <> "" Then
 Rows(ilastrow2 + 3).Value = Rows(i).Value
 j = ilastrow2 + 3
 Cells(j, "K").Value = mixlokaal.Offset(0, 3).Value
 End If
 
 If mixlokaal.Offset(0, 4).Value <> "" Then
 Rows(ilastrow2 + 4).Value = Rows(i).Value
 j = ilastrow2 + 4
 Cells(j, "K").Value = mixlokaal.Offset(0, 4).Value
 End If
  

 End If

 Next mixlokaal
 Next i

End With

With Application
    .EnableEvents = True
    .ScreenUpdating = True
    .DisplayAlerts = True
End With

End Sub

hier kan je het document vinden, ik hoop dat de link werkt
https://1drv.ms/x/s!AsIc6FiZ_zTXkiCTTLdB0ddDVOOH?e=OBQJfG

PS: dit is de versie waar ik het al heb laten draaien, dus de rijen onder de tabel, zijn de gekopieerde rijen
 
Laatst bewerkt:
Waarom niet dat document gewoon hier plaatsen?
 
Ik krijg 'm wél gedownload, maar ik heb toch eerst een paar biertjes nodig voordat ik voldoende moed heb verzameld om er überhaupt maar een blik op te kunnen werpen :). Ik zag wél een aantal data fouten in je jaartal kolom. Waardoor de samenstelformule (die overigens veel korter kan: =JAAR(B3)&" - "&RECHTS("00"&ISO.WEEKNUMMER(B3);2) niet overal goed werkt. En je haalt gegevens uit werkboeken die je niet meelevert. Kan ook een probleem zijn.

Je kunt de bestanden overigens ook vanuit je OneDrive gewoon delen; je hoeft ze dan niet vanuit Office 365 te openen. Want niet iedereen heeft dat.
 
Probeer je eens te verdiepen in array's als je met veel data werkt. De hele code is wel een erg onduidelijk geheel. Om de tabel aan te vullen

Code: 
Sub VenA()
  Dim j As Long, jj As Long, ar, ar1, r, x, y
  ar = Sheets("brongegevens").ListObjects(1).DataBodyRange
  ar1 = Sheets("Bereiken").Cells(1, 16).CurrentRegion
  x = Application.Transpose(Application.Index(ar1, 0, 1))
  Set d = CreateObject("Scripting.Dictionary")
  For j = 2 To UBound(ar)
    r = Application.Match(ar(j, 11), x, 0)
    If IsNumeric(r) Then
      y = Application.Index(ar, j, 0)
      For jj = 2 To UBound(ar1, 2)
        If ar1(r, jj) <> "" Then
          y(11) = ar1(r, jj)
          y(2) = Format(y(2), "m-d-yyyy")
          d(d.Count + 1) = y
        End If
      Next jj
    End If
  Next j
  Sheets("brongegevens").ListObjects(1).ListRows.Add.Range.Resize(d.Count, UBound(ar, 2)) = Application.Index(d.items, 0)
End Sub

(staat ook wel even te stampen)
 
Ah ja, misschien interessant om te weten, het gaat enkel over de macro: mcrmixlokalen

De andere macro s heb ik al laten draaien.
 
VenA, hartelijk bedankt! Het werkt super.

Ik ken inderdaad vrij weinig (of niets) van Array s. Ik ga jouw code ook eens proberen te ontcijferen, op een rustiger moment op het werk.
Ik probeer me maar met VBA te behelpen en ben al heel blij waar ik nu geraakt ben, maar ik denk dat ik inderdaad vaak heel omslachtige en trage code maak door een gebrek aan kennis.

Nog eens super bedankt :).
 
Waarom gebruik je niet de ingebouwde Excel-faciliteiten ?

Code: 
Sub M_snb()
    Blad3.ListObjects(1).Range.AutoFilter 11, Filter(Application.Transpose(Blad2.Columns(16).SpecialCells(2).Offset(1).SpecialCells(2)), ""), 7
    Sheets.Add , Sheets(Sheets.Count)
    Blad3.ListObjects(1).Range.SpecialCells(12).Copy Sheets(Sheets.Count).Cells(1)
    Blad3.ListObjects(1).Range.AutoFilter
End Sub
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan