delen rows achter de vorige regel plaatsen.

[GBSpijkers]

Ik het een database gekregen waar op iedere regel een nieuw onderzoek bij een patient staat. de rest van de gegevens blijft een aantal regels hetzelfde tot ik alle onderzoeken van die patient gehad heb en hij aan de volgende begint. ik wil die onderzoeken allemaal op 1 regel hebben achter de eerste entry van die patient.

ik heb de volgende code al gemaakt, alleen het kopieren lukt me niet om goed op te zetten.

Private Sub CommandButton1_Click()
Dim Rng As Integer
For Rng = 2 To Rng = 5006
   If Err.Number = 0 Then
     If Range(Rng, 1).Value = Range(Rng - 1, 1).Value Then Sheets("Blad1").Cells(Rng, Columns.Count).End(xlToLeft).Offset(, 1).Resize(, 3) = Sheets("Blad1").Cells(Rng + 1, 10).Resize(, 3).Value And Row(Rng).Delete
   End If
   Err.Clear
Next
End Sub

Met name vraag ik me af of het volgende deel van de code wel klopt

Sheets("Blad1").Cells(Rng, Columns.Count).End(xlToLeft).Offset(, 1).Resize(, 3) = Sheets("Blad1").Cells(Rng + 1, 10).Resize(, 3).Value

in het voorbeeld ziet u het voor op blad1 en op blad 2 het effect wat ik hoop bewerk te stellen.

ik hoop dat iemand mij kan helpen

 

[GBSpijkers]

ik heb de code nog iets aangepast om te kijken of ik het daarmee aan het werk krijg dit lukt ook niet maar geeft misschien wel duidelijker weer wat ik hebben wil

Sub test()
 Dim Rng as Integer
 On Error Resume Next
    For Rng = 2 to Rng =5006
      If Cells(Rng,1).value = Cells(Rng - 1, 1).value Then 
        Sheets("blad1").cells(Rng-1, Columns.count).End(xlToLeft).Offset(, 1).Resize(,15) = Sheets("Blad1").Range(cells(Rng, 1), Cells(Rng, 11)).Value
        Sheets("Blad1").Range(",Rng:,Rng").Remove
      End If
    Next
End Sub

Deze code zou de hele regel kopieren, dit zou ook geen probleem zijn alle dubbele kolomen komen dan toch onder elkaar te staan en kunnen dan met de hand wel verwijderd worden als dat makkelijker is.

Maar ook bij deze krijg ik hem niet werkend.

een geheel eigen code mag natuurlijk ook.

ik hoop op een spoedige reactie

 

[Warme bakkertje]

Test deze eens uit

Sub test()
 Dim Rng As Integer
 On Error Resume Next
    For Rng = 5006 To 2 Step -1
    If Cells(Rng, 1).Value = Cells(Rng - 1, 1).Value Then
         Sheets("Blad1").Range(Cells(Rng, 1), Cells(Rng, Columns.Count).End(xlToLeft)).Copy _
                Sheets("blad1").Cells(Rng - 1, Columns.Count).End(xlToLeft).Offset(, 1)
        Sheets("Blad1").Cells(Rng, 1).EntireRow.Delete
      End If
    Next
End Sub

 

[GBSpijkers]

Heel erg bedankt hij doet het prima.

 

[snb]

Wellicht wat sneller bij grote aantallen:

Sub tst()
  sq = Cells(1, 1).CurrentRegion
  x = UBound(sq, 2)
  
  For j = UBound(sq) To 2 Step -1
    If sq(j, 1) = sq(j - 1, 1) Then
      sq(j - 1, x) = sq(j - 1, x) & "|" & sq(j, x - 2) & "|" & sq(j, x - 1) & "|" & sq(j, x)
      sq(j, 1) = ""
    End If
  Next
  Cells(1, 1).CurrentRegion = sq
  Columns(1).SpecialCells(4).EntireRow.Delete
  Columns(x).TextToColumns , 1, -4142, , False, False, False, False, True, "|"
End Sub

 

[GBSpijkers]

Jouw kennende zal deze macro vast werken, helaas snap ik niet volledig wat hij doet. dat is jammer want dan kan ik hem minder makkelijk aanpassen aan andere omstandigheden, maar voor een heel grote database is dat wel makkelijk.

hoewel de vorige macro met 5000 regels met 1,5 minuten al klaar was dat vond ik het best snel gaan.

 

[snb]

Sub tst()
  sq = Cells(1, 1).CurrentRegion                               [COLOR="SeaGreen"]' lees het gebied met gegevens in in matrixvariable sq[/COLOR]
  x = UBound(sq, 2)                                                 [COLOR="seagreen"]' bepaal het nummer van de laatste kolom[/COLOR]
  
  For j = UBound(sq) To 2 Step -1                             [COLOR="seagreen"]' doorloop de matrix vanaf de laatste rij[/COLOR]
    If sq(j, 1) = sq(j - 1, 1) Then                                 [COLOR="seagreen"]' als het opnamenummer in de rij erboven hetzelfde is[/COLOR]
      sq(j - 1, x) = sq(j - 1, x) & "|" & sq(j, x - 2) & "|" & sq(j, x - 1) & "|" & sq(j, x)  [COLOR="seagreen"]' voeg dan in de laatste kolom van de regel erboven de gegevens toe uit de laatste 3 kolommen van de huidige rij gescheiden door een pipeline[/COLOR]
      sq(j, 1) = ""                                                       [COLOR="seagreen"]'  maak de cel met het opnamenummer leeg[/COLOR]
    End If
  Next

  Cells(1, 1).CurrentRegion = sq                               [COLOR="seagreen"]' zet de matrixvariabele in het gegevensgebied; m.a.w. vervang de gegevens door de nieuwe gegevens in de matrixvariabele[/COLOR]

  Columns(1).SpecialCells(4).EntireRow.Delete          [COLOR="seagreen"]' verwijder alle regels zonder opnamenummer[/COLOR]
  Columns(x).TextToColumns , 1, -4142, , False, False, False, False, True, "|"  [COLOR="seagreen"]' splits de laatste kolom met de pipeline als scheidingsteken[/COLOR]
End Sub

Deze macro doet er een fraktie van een seconde over.

 

[GBSpijkers]

Heel erg bedankt voor de uitleg van de macro ik ga hem morgen goed doorlopen om te kijken of ik het nu wel begrijp. Zo leer ik er ook weer van

Gerben