VBA waarde kopieren naar een lege cel in een bepaald bereik

[Rens80]

Hoi,

Ik heb het volgende probleem. In het voorbeeldbestand wil ik de waarde van Blad2 cel B4 kopieren naar de eerstvolgende lege cel in Blad1, kolom J binnen het aangeduide kader. Daarnaast moet Blad2, B5 gekopieerd worden naar blad1 dezelfde rij kolom P binnen het kader.

Ik heb al een hele tijd zitten zoeken en allerlei formules proberen aan te passen, maar ik krijg alleen foutmeldingen. Zie ook het voorbeeldbestand voor de laatste poging.

ALvast dank voor de hulp

 

[cow18]

een mogelijke manier

Sub kopieren()
   On Error Resume Next 'doorgaan bij fouten
   Set c = Sheets("blad1").Range("J11:J22").SpecialCells(xlCellTypeBlanks).Cells(1)   '1e lege cel in dat bereik
   On Error GoTo 0
   If Not c Is Nothing Then                      'zo'n cel gevonden
      c.Value = Sheets("blad2").Range("B4").Value   'naam wegschrijven
      c.Offset(, 6).Value = Sheets("blad2").Range("B5").Value   'bedrag wegschrijven
   Else
      MsgBox "er zijn geen lege cellen meer in dat bereik", vbCritical   'foutje bedankt
   End If
End Sub

 

[HSV]

Ook een manier.

Sub hsv()
 With Sheets("blad1")
  .Cells(Application.Max(11, .Cells(Rows.Count, 10).End(xlUp).Offset(1).Row), 10).Resize(, 7) = Array(Sheets("blad2").Range("b4").Value, , , , , , Sheets("blad2").Range("b5").Value)
 End With
End Sub

 

[Rens80]

Allebei dank voor de hulp.

@cow18: Ik krijg een foutmelding als het bereik vol is ipv de MsgBox

 

[cow18]

code van HSV is kort en bondig, maar zal niet altijd binnen het bereik schrijven, omdat er niet gecheckt wordt naar rijnummer

Sub hsv2()
   With Sheets("blad1").Cells(Rows.Count, 10).End(xlUp).Offset(1)   '1e vrije cel in J-kolom
      Select Case .Row                           'welke rij ?
         Case Is <= 11: Set c = .Offset(11 - .Row)   'minstens 11e rij
         Case 11 To 21: Set c = .Cells(1)        'zit OK
         Case Else: MsgBox "buiten bereik", vbCritical: Exit Sub   'valt er buiten
      End Select
      c.Resize(, 7) = Array(Sheets("blad2").Range("b4").Value, , , , , , Sheets("blad2").Range("b5").Value)
   End With
End Sub

mijn versie, waar je zelf nog een keuze moet maken uit 2 varianten afhankelijk of je de tussenliggende cellen mag overschrijven of niet
Ook volg ik misschien niet volledig de vraag, ik kijk naar de 1e lege cel binnen dat bereik, dus zal ik eventueel een tussenliggende lege cel gebruiken.
Is dat gewenst ?

Sub kopieren()
'On Error Resume Next                          'doorgaan bij fouten
   With Sheets("blad1")                          'dit werkblad
      Set c = Intersect(.Columns("J").SpecialCells(xlCellTypeBlanks), .Range("J11:J21"))
   End With
   If Not c Is Nothing Then
      'ofwel als de tussenliggende cellen mogen overschreven worden
      c.Cells(1).Resize(, 7).Value = Array(Sheets("blad2").Range("b4").Value, , , , , , Sheets("blad2").Range("b5").Value)   'zoals HSV

      'ofwel als de tussenliggende cellen niet overschreven mogen worden
      With c.Cells(1)
         .Value = Sheets("blad2").Range("B4").Value   'naam wegschrijven
         .Offset(, 6).Value = Sheets("blad2").Range("B5").Value   'bedrag wegschrijven
      End With
   Else
      MsgBox "er zijn geen lege cellen meer in dat bereik", vbCritical   'foutje bedankt
   End If
End Sub