• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

VBA waarde kopieren naar een lege cel in een bepaald bereik

Status
Niet open voor verdere reacties.

Rens80

Gebruiker
Lid geworden
2 apr 2020
Berichten
46
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
 

Bijlagen

een mogelijke manier
Code:
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
 
Laatst bewerkt:
Ook een manier.
Code:
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
 
Allebei dank voor de hulp.

@cow18: Ik krijg een foutmelding als het bereik vol is ipv de MsgBox
 
code van HSV is kort en bondig, maar zal niet altijd binnen het bereik schrijven, omdat er niet gecheckt wordt naar rijnummer
Code:
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 ?
Code:
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
 
Laatst bewerkt:
Status
Niet open voor verdere reacties.
Terug
Bovenaan Onderaan