cellen kopiëren met behulp van VBA

[arjancuijpers]

Beste,

Ik heb een sheet waarbij ik als er in kolom E het woord "glas"staat de cellen A t/m F van die betreffende rij geselecteerd en gekopieerd moeten worden naar een andere geopend bestand.

zie bijlage

Mvg

Bekijk bijlage kavel20a.xlsx

 

[HSV]

In onderstaande code wordt het voor nu naar een tweede blad geschreven als je die even tevoren aanmaakt.

Sub hsv()
Dim sn, arr, i As Long, j As Long
ReDim arr(6, 0)
sn = Sheets(1).Cells(1).CurrentRegion
  For i = 1 To UBound(sn)
    If InStr(1, sn(i, 5), "glas", 1) Then
      For j = 1 To 6
        arr(j - 1, UBound(arr, 2)) = sn(i, j)
      Next j
     ReDim Preserve arr(6, UBound(arr, 2) + 1)
    End If
  Next i
 With Sheets(2)
   .Columns(1).NumberFormat = "@"
   .Columns(6).NumberFormat = "0.00"
   .Cells(1).Resize(UBound(arr, 2), 7) = Application.Transpose(arr)
 End With
End Sub

 

[arjancuijpers]

In onderstaande code wordt het voor nu naar een tweede blad geschreven als je die even tevoren aanmaakt.

Sub hsv()
Dim sn, arr, i As Long, j As Long
ReDim arr(6, 0)
sn = Sheets(1).Cells(1).CurrentRegion
  For i = 1 To UBound(sn)
    If InStr(1, sn(i, 5), "glas", 1) Then
      For j = 1 To 6
        arr(j - 1, UBound(arr, 2)) = sn(i, j)
      Next j
     ReDim Preserve arr(6, UBound(arr, 2) + 1)
    End If
  Next i
 With Sheets(2)
   .Columns(1).NumberFormat = "@"
   .Columns(6).NumberFormat = "0.00"
   .Cells(1).Resize(UBound(arr, 2), 7) = Application.Transpose(arr)
 End With
End Sub

Dankje HSV
werkt perfect.