Regels kopiëren tussen bepaalde waarden

[Danielle22]

Hallo,

Is het ook mogelijk met behulp van VBA om regels te kopiëren die tussen bepaalde waardes liggen en die dan naar een nieuw blad gekopieerd wordt?

Ik heb een blad met erg veel data (zie voorbeeld bijlage).

Dus als er TEST staat dan moet die de regels kopiëren die tussen TEST en EINDE TEST staat kopiëren naar een nieuw blad. Dus dat die zelf een nieuw blad aanmaakt en daarheen kopieert.

Zou iemand mij kunnen vertellen hoe ik dit kan realiseren?

Alvast heel erg bedankt voor de reacties.

Groetjes,

Danielle
Bekijk bijlage testv1.xls

 

[HSV]

Sub HSV()
   Dim iws As Integer, i As Long, j As Long, xcolumns As Integer, bld As Integer
     For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
       For j = 1 To Cells(Rows.Count, 1).End(xlUp).Row - 1
        If Cells(i, 1).Offset(j) = "TEST" Or Cells(i, 1).Offset(j) = "EINDE TEST" Then Exit For
         If Cells(i, 1) = "TEST" And Cells(i, 1).Offset(j) <> "EINDE TEST" Then
          If Cells(i, 1).Offset(j) = "" Then Exit For
        iws = WorksheetFunction.CountIf(Range(Range("A1"), Cells(i, 1)), "TEST") + 1
            If bld <> iws Then
              bld = iws
                Sheets.Add after:=Sheets(Sheets.Count)
              End If
          Sheets("Data").Activate
       With Sheets(iws)
         If .Cells(1, 1) = "" Then
           xcolumns = Columns(1).CurrentRegion.Columns.Count
             .Cells(1, 1).Resize(, xcolumns).Value = Cells(i, 1).Offset(j).Resize(, xcolumns).Value
          Else
             .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(, xcolumns).Value = Cells(i, 1).Offset(j).Resize(, xcolumns).Value
         End If
        End With
      End If
    Next j
  Next i
End Sub

 

[Danielle22]

Hoi HSV,

Heel erg bedankt voor je hulp :thumb:.

Ik ga dit gelijk toepassen en verder uitbouwen op mijn data.

Groetjes,

Danielle