Foutmelding 91 objectvariabele of blokvariabele with is niet ingesteld.

[AEHofman]

Hallo,

Wie kan mij helpen dit probleem op te lossen.
Ik kan de fout niet vinden in mijn code.
Ik heb van alles geprobeerd maar hij blijft deze melding geven.


Om de code te starten in de bijlage, klik je op de knop Rooster ophalen.

Sub WerkOverzetten()
'Een macro die de roosters van ieder individueel personeelslid
'ophaald uit rooster A en daarna bij diezelfde persoon in het basisrooster de gegevens neerzet.
'In dit voorbeeld mag hij de eerste 2 personeelsleden 1255 en 1355 wel ophalen maar de derde 1655 niet
'het is raar maar waar het heeft gewerkt maar toen ik er mee verder wilde gaan nadat ik het bestand had
'opgeslagen kwam telkens de foutmelding "91 objectvariabele of blokvariabele with is niet ingesteld"
 

 Dim myRange As Range
   Dim i As Long, j As Long
   Set myRange = Range("RoosterA") '= (A2:A10)
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False
   
   For i = 1 To myRange.Rows.Count
   
        If myRange.Cells(i).Value > 100 Then ' Onderliggende cellen A3 en A4 kunnen wel waarden bevatten maar noot hoger dan 100.
           
              Set myRange = Range("RoosterA")
              Set a = Range("RoosterA").Find(myRange.Cells(i).Value) 'Hier moet hij de waarde 1255 vinden.
              
              With Range("RoosterA")
              myRange.Cells(i).Select
              Selection.Offset(0, 3).Resize(Selection.Rows.Count + 2, _
              Selection.Columns.Count + 5).Copy 'Hier moet hij het gebied (D13:I15)selecteren doet hij ook.
              End With
              
              With Range("Basisrooster") '= (A13:A21)
              Set myRange = Range("Basisrooster")
              Set b = Range("Basisrooster").Find(myRange.Cells(i).Value) 'Hier moet hij 1255 opnieuw vinden in basisrooster.
              End With
              
              If a.Value = b.Value Then 'Checken of beide waarden gelijk zijn.
              
              myRange.Cells(i).Offset(0, 3).Resize(2, 6).PasteSpecial 'Alleen plakken als beide gevonden waarden gelijk zijn.
         End If
        End If
    Next i

   Application.CutCopyMode = False
   Application.ScreenUpdating = True
   Application.DisplayAlerts = True
End Sub

 

[MDN111]

Dag AEHofman !

Na volgende wijziging lijkt het bij mij te werken:

Sub WerkOverzetten()
'Een macro die de roosters van ieder individueel personeelslid
'ophaald uit rooster A en daarna bij diezelfde persoon in het basisrooster de gegevens neerzet.
'In dit voorbeeld mag hij de eerste 2 personeelsleden 1255 en 1355 wel ophalen maar de derde 1655 niet
'het is raar maar waar het heeft gewerkt maar toen ik er mee verder wilde gaan nadat ik het bestand had
'opgeslagen kwam telkens de foutmelding "91 objectvariabele of blokvariabele with is niet ingesteld"
 

 Dim myRange As Range
   Dim i As Long, j As Long
   Set myRange = Range("RoosterA") '= (A2:A10)
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False
   
   For i = 1 To myRange.Rows.Count
   
        If myRange.Cells(i).Value > 100 Then ' Onderliggende cellen A3 en A4 kunnen wel waarden bevatten maar noot hoger dan 100.
           
              Set myRange = Range("RoosterA")
              Set a = Range("RoosterA").Find(myRange.Cells(i).Value, [COLOR="#FF0000"]LookIn:=xlValues[/COLOR]) 'Hier moet hij de waarde 1255 vinden.
              
              With Range("RoosterA")
              myRange.Cells(i).Select
              Selection.Offset(0, 3).Resize(Selection.Rows.Count + 2, _
              Selection.Columns.Count + 5).Copy 'Hier moet hij het gebied (D13:I15)selecteren doet hij ook.
              End With
              
              With Range("Basisrooster") '= (A13:A21)
              Set myRange = Range("Basisrooster")
              Set b = Range("Basisrooster").Find(myRange.Cells(i).Value, [COLOR="#FF0000"]LookIn:=xlValues[/COLOR]) 'Hier moet hij 1255 opnieuw vinden in basisrooster.
              End With
              
              If a.Value = b.Value Then 'Checken of beide waarden gelijk zijn.
              
              myRange.Cells(i).Offset(0, 3).Resize(2, 6).PasteSpecial 'Alleen plakken als beide gevonden waarden gelijk zijn.
         End If
        End If
    Next i

   Application.CutCopyMode = False
   Application.ScreenUpdating = True
   Application.DisplayAlerts = True
End Sub
Attached Files Attached Files

Grtz,
MDN111.

 

[snb]

Ik zou het zo doen:

Sub M_snb()
   sn = Blad1.Range("A2:A10")
   sp = Blad1.Range("D2:I10")
   sq = Blad1.Range("A12:A21")
   sr = Blad1.Range("D12:I21")
   
   For j = 1 To UBound(sn)
      If sn(j, 1) <> "" And Not IsError(Application.Match(sn(j, 1), sq, 0)) Then
         y = Application.Match(sn(j, 1), sq, 0)
         For jj = 1 To UBound(sp, 2)
             sp(j, jj) = sr(y, jj)
             sp(j + 1, jj) = sr(y + 1, jj)
         Next
      End If
    Next
    
    Blad1.Range("D2:I10") = sp
End Sub