Gegevens per mdw door kopiëren

[Nicolett]

Goedemiddag,
Ik heb een bestand die uit ons systeem komt waarbij er gegevens door gekopieerd moeten worden. Maar er zitten steeds tussenregels tussen. Is dit mogelijk met een formule of bijv. een macro? Het lukt mij niet om dan de gegevens juist te krijgen. Elke lijst kan andere namen bevatten en de volgorde van namen kan ook wijzigen. Ook het aantal regels dat door gekopieerd moet worden blijft. Het vervelende is ook dat de lijst die we uit ons systeem krijgen steeds kopbladen heeft (zie de dikgedrukte regels).

Ik hoor graag of er een mogelijkheid is om dit te automatiseren in Excel.

In de bijlage een voorbeeld. In het eerste tabblad hoe de gegevens uit ons systeem komen en op het tweede tabblad hoe de gegevens dienen komen te staan. Kolom A en B wordt door gekopieerd naar de regels onder de naam. Alle overige kolommen dienen niet aangepast te worden.

Alvast bedankt voor de hulp!

 

[Haije]

Nicolett,

komt er een tekstbestand uit jullie systeem?

Zo ja, kun je dat eens plaatsen?

 

[sylvester-ponte]

zo iets onder een knopje hangen:

Sub vervang()
    Dim Tabel As Range, Naam As Range, Volgnr, Verw, Tempnr, TempN
    Set Tabel = Range(Cells(6, 2), Cells(Cells.Rows.Count, 2).End(xlUp))
    For Each Naam In Tabel
         If Naam.Offset(, -1) = 1 And Naam = "N" Then
            Naam.Offset(, -1) = Naam.Offset(-1, -1)
            Naam.Offset(, -1).HorizontalAlignment = xlLeft
            Naam = Naam.Offset(-1)
        End If
    Next
End Sub

 

[sylvester-ponte]

Nicolett, ik heb hem aangepast (zo doet hij het ook bij de pagina overgang).

Sub vervang()
    Dim Tabel As Range, Naam As Range, Volgnr As String, Verw As String
    Set Tabel = Range(Cells(6, 2), Cells(Cells.Rows.Count, 2).End(xlUp))
    For Each Naam In Tabel
    Naam.Select
        If IsNumeric(Naam.Offset(, -1)) And Naam.Offset(, -1) <> 1 And Naam.Offset(, -1) <> "" Then
            Naam.Offset(, -1).NumberFormat = "@"
            Volgnr = Naam.Offset(, -1)
            Verw = Naam
        ElseIf Naam.Offset(, -1) = 1 Then
            Naam.Offset(, -1).NumberFormat = "@"
            Naam.Offset(, -1) = Volgnr
            Naam.Offset(, -1).HorizontalAlignment = xlLeft
            Naam = Verw
        End If
    Next
End Sub

 

[Nicolett]

Bedankt voor je hulp! Het is gelukt. Is er ook een code misschien om alle headers in 1 keer te verwijderen? losstaand van bovenstaande macro? Dat zou ook heel erg helpen! Ik moet het nu handmatig verwijderen allemaal.

 

[sylvester-ponte]

wat haal je precies wet als je een header verwijdert?

 

[Nicolett]

Zie de geel gearceerde regels in de bijlage. Daarnaast verwijder ik ook alle lege regels ertussenin.

 

[sylvester-ponte]

bedoel je dat de legeregel boven totaal ook verdwijnt?

 

[Nicolett]

ja, dat klopt. De totaal regel wordt ook verwijderd.
Het proces verloopt eigenlijk zo:
- Alle gegevens door kopiëren
- Alle headers verwijderen
- Alle tussenregels verwijderen (inclusief totaal regel)
We hebben als het ware alleen de gegevens nodig van de regels waar een salariscomponent (zie kolom C) in aangegeven staat met een getal. En dan de hoofdkoppen.

Zie in de bijlage ook de oranje gemarkeerde regels. Dit zijn de regels die we ook verwijderen. In tabblad 2 hoe de gegevens uiteindelijk dan komen te staan.

 

[Haije]

Nicolett,

komt er een tekstbestand uit jullie systeem?

Zo ja, kun je dat eens plaatsen?

 

[Nicolett]

Hi,

Ja dat komt er wel uit, maar dan kan ik je niet sturen. Daar staan te veel persoonlijke gegevens in. Ik converteer het bestand altijd naar Excel en werk vanuit daar.

 

[Haije]

Als ik lees wat er allemaal uiteindelijk verwijderd moet worden lijkt het me veel eenvoudiger om inleesmacro te maken die alles in één procedure doet.

En...
het hoeft niet een groot bestand te zijn
ook in een tekstbestand kun je gevoelige gegevens vervangen door fictieve gegevens

 

[VenA]

met

Columns(3).SpecialCells(4).EntireRow.Delete

kom je een heel eind.

 

[sylvester-ponte]

of

Sub vervangEnVerwijder()
    Dim Tabel As Range, Naam As Range, Volgnr, Verw, Tempnr, TempN
    Set Tabel = Range(Cells(9, 2), Cells(Cells.Rows.Count, 2).End(xlUp))
    For Each Naam In Tabel
        Do Until Val(Naam.Offset(1, -1)) <> 0 Or Intersect(Naam.Offset(1), Tabel) Is Nothing
            Naam.Offset(1).EntireRow.Delete
        Loop
         If Naam.Offset(, -1) = 1 And Naam = "N" Then
            Naam.Offset(, -1) = Naam.Offset(-1, -1)
            Naam.Offset(, -1).HorizontalAlignment = xlLeft
            Naam = Naam.Offset(-1)
        End If
    Next
End Sub

 

[VenA]

Iets sneller en wat minder lege regels in het eind resultaat.

Sub VenA()
  Dim j As Long, c00 As String, ar, a, b, y
  With Sheets("prm543p1")
  .Columns(2).SpecialCells(4).EntireRow.Delete
    ar = .Cells(1).CurrentRegion
    .UsedRange.ClearContents
      c00 = "4 5"
      For j = 1 To UBound(ar)
        If IsNumeric(ar(j, 1)) And ar(j, 1) > 1 Then
          a = ar(j, 1)
          b = ar(j, 2)
         Else
          If ar(j, 1) & ar(j, 2) = "1N" Then
            ar(j, 1) = a
            ar(j, 2) = b
            c00 = c00 & " " & j
          End If
        End If
      Next j
      y = Application.Index(ar, Application.Transpose(Split(c00)), Application.Transpose([row(1:9)]))
      .Cells(1).Resize(UBound(y), 9) = y
    End With
End Sub