Gegevens transponeren en kopiëren naar volgende lege regel op volgend tabblad

[carlocarlo]

In krijg dagelijks Excellijsten die ik moet samenvoegen naar 1 bestand. Ik loop daar tegen een paar zaken aan, te weten:
- De gegevens staan allemaal in een kolom. Om er mee te kunnen werken moet de waarde van bijvoorbeeld regel 11 van tabblad 'invoer' in kolom A van tabblad 'totaal overzicht' komen te staan. De waarde uit regel 6 van tabblad 'invoer' naar kolom B van het tabblad '' totaal overzicht' komen.
- Vanaf regel 42 van tabblad 'invoer' moet de waarde naar de eerstvolgende regel in Kolom A van het tabblad 'totaal overzicht' worden geplaatst,, de waarde van regel 43 naar kolom B enz.
- Dit moet zich herhalen totdat alle informatie van het tabblad 'invoer' netjes onder elkaar in het volgende tabblad staat.

Wie O Wie kan mij helpen aan een macro?

 

[gast0660]

Hoi,

De gegevens staan allemaal in een kolom. Om er mee te kunnen werken moet de waarde van bijvoorbeeld regel 11 van tabblad 'invoer' in kolom A op het volgende tabblad komen te staan. De waarde uit regel 6 van tabblad 'invoer' naar kolom B op het volgende tabblad.

,
Dit stuk is mij volkomen onduidelijk.
Kan je hier iets mee?
In bijlage een (simpel) vbtje
Groet

 

[sylvester-ponte]

deze heeft iets minder programma regels dan mijn vorige code (die heb ik dan ook verwijderd ), maar doet het zelfde:

Sub Overzetten()
    Dim Van As Range, Naar As Range
    Set Naar = Sheets("totaal overzicht").Cells(1, 1) 'hier begint de invoer op blad "totaal overzicht"
    For Each Van In Sheets("invoer").Columns(1).SpecialCells(xlCellTypeConstants) 'doorloop alleen de cellen die gevuld zijn
        If Van.Row > 1 Then If Van(0, 1) = "" Then Set Naar = Naar(2, 2 - Naar.Column) 'was boven Van een lege cel dan nieuwe regel 
        Naar = Van 'Naar wordt ingevuld
        Set Naar = Naar(1, 2) 'Naar wordt alvast een opzij gezet om de volgende invoer te ontvangen
    Next
End Sub

 

[sylvester-ponte]

hallo Jack, ik heb net als jij aangenomen dat met het volgende tabblad het blad "totaal overzicht" bedoeld wordt

 

[gast0660]

Hoi Sylvester,
Dat begrijp ik, zoals ik al aangaf een beetje onduidelijk
Je code ziet alvast goed uit:thumb:
Groet

 

[carlocarlo]

Bedankt voor jullie reactie.

Het werkt. Ontzettend bedankt. Mijn waardering is groot.
Klopt het dat alleen de unieke waarden worden gekopieerd en dat ik niet 2x dezelfde informatie kan kopiëren?

 

[sylvester-ponte]

carlo,
probeer het eerst eens uit.

en geef dan aan wat je nog meer wil.

 

[VenA]

Met een iets langere code maar wel iets sneller.

Sub VenA()
For Each cl In Sheets("invoer").Range("A1:A" & Sheets("invoer").Cells(Rows.Count, 1).End(xlUp).Row + 1)
   If cl <> "" Then
        c00 = c00 & "|" & cl.Value
      Else
        If cl.Offset(-1) <> "" Then
            Sheets("totaal overzicht").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(1, UBound(Split(Mid(c00, 2)))) = Split(Mid(c00, 2), "|")
            c00 = ""
        End If
   End If
Next cl
End Sub

Je hebt in jouw tabjes wat lege cellen staan die niet echt leeg zijn. Deze zal je eerst moeten verwijderen.

 

[sylvester-ponte]

VenA, als de eerste cel van de invoer leeg is gaat het mis.

die spaties in de invoer zijn misschien bedoeld om lege regels of cellen in de uitvoer te creëren .

 

[HSV]

Wat @VenA al aangaf; delete de cellen die leeg lijken (dus niet verwijderen).

Sub hsv()
Dim area As Range
For Each area In Sheets(1).Columns(1).SpecialCells(2).Areas
 Sheets(2).Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, area.Rows.Count) = Application.Transpose(area)
Next area
End Sub

 

[sylvester-ponte]

Harry, heel mooi gemaakt.
en hij doet het ook met lege cellen aan het begin.
toch die van VenA is sneller. maar ja, die mag weer niet beginnen met een lege cel.

ik denk dat het nog wel sneller kan. maar mooier ?? dat denk ik niet.

 

[VenA]

@sylvester-ponte,

Ik ga natuurlijk uit van het voorbeeldbestandje. Waar het mis kan gaan is niet zo moeilijk te ondervangen net als het wegschrijven op de tweede regel.:d

 

[HSV]

Ik heb het niet op snelheid getest.

Sub hsv()
Dim area As Range, arr(), j As Long, y As Long, n As Long
With Sheets(1)
ReDim arr(.Columns(1).SpecialCells(2).Areas.Count, 1)
 For Each area In .Columns(1).SpecialCells(2).Areas
  For j = 1 To area.Rows.Count
    ReDim Preserve arr(.Columns(1).SpecialCells(2).Areas.Count, n + 2)
    arr(y, j - 1) = area(j, 1)
    n = n + 1
  Next j
    y = y + 1
 Next area
Sheets(2).Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(arr), n) = arr
End With
End Sub

Ps. Er is vast nog wat tijd te winnen door ".Columns(1).SpecialCells(2).Areas.Count" in een variabele te zetten zonder te declareren.

 

[sylvester-ponte]

ik weet niet precies waarom maar deze is weer veel sneller dan die van VenA

Sub svp()
i00 = Sheets("invoer").Range("A1:A" & Sheets("invoer").Cells(Rows.Count, 1).End(xlUp).Row + 1)
u = UBound(i00)
If i00(1, 1) <> "" Then c00 = "|" & i00(1, 1)
For i = 2 To u
    If i00(i, 1) <> "" Then
        If i00(i - 1, 1) = "" Then 'afdrukken en nieuwe regel
            s = Split(Mid(c00, 2), "|")
            Sheets("totaal overzicht").Cells(r + 1, 1).Resize(, UBound(s) + 1) = s
            r = r + 1
            c00 = ""
        End If
        c00 = c00 & "|" & i00(i, 1)
    End If
Next
End Sub

 

[HSV]

Ik heb het even in een voorbeeldje gegoten.
Vier codes.
Elke code wordt uitgevoerd op max snelheid.
'screenupdating
'option explicit

Het ligt er wel aan waar de gegevens staan wat betreft de snelheid van de codes.
Helaas worden in de code van Sylvester de laatste gegevens niet meegenomen (het zal vast iets kleins zijn).

 

[sylvester-ponte]

Harry, ik heb hem aangepast.
maar ik zie je test programma niet.

Sub svp()
i00 = Sheets("invoer").Range("A1:A" & Sheets("invoer").Cells(Rows.Count, 1).End(xlUp).Row + 1)
u = UBound(i00)
If i00(1, 1) <> "" Then c00 = "|" & i00(1, 1)
For i = 2 To u
    If i00(i, 1) <> "" Then
        If i00(i - 1, 1) = "" Then 'afdrukken en nieuwe regel
            s = Split(Mid(c00, 2), "|")
            Sheets("totaal overzicht").Cells(r + 1, 1).Resize(, UBound(s) + 1) = s
            r = r + 1
            c00 = ""
        End If
        c00 = c00 & "|" & i00(i, 1)
    End If
Next
s = Split(Mid(c00, 2), "|")
Sheets("totaal overzicht").Cells(r + 1, 1).Resize(, UBound(s) + 1) = s
End Submaar

 

[HSV]

Sorry verkeerde, ik heb het bijgewerkt incl. jouw goed code.

 

[sylvester-ponte]

harry, bij mij werkt het niet.
om het te laten werken moet ik eerst alle variabelen declareren.
is daar iets aan te doen.
de Option Explicit heb je al uitgeschakeld.

 

[HSV]

Vreemd, ik heb geen idee Sylvester.
In de opties heb ik 'declareren vereist' aangevinkt.
Door een apostrof te zetten voor 'option Explicit' maakt dit het declareren te niet.
Of er nog een ander instelling is zou ik niet weten.

Hoe lijken de codes het te doen met declareren?
Iets trager weet ik, maar de code van jou is echt snel op zoveel rijen. :thumb:

 

[carlocarlo]

Beste allen, ik loop toch vast op het volgende. Ik heb de Macro gebruikt van sylvester-ponte van 16-01-2016 om 12:45 uur. Op de laatste regel heb ik de toevoeging 'maar' achter 'sub' weggehaald.

De macro kan ik maar 1x gebruiken om de gegevens door te voeren naar het tabblad 'totaal overzicht'. Als ik dezelfde gegevens nogmaals aan het tabblad wil toevoegen dan zie ik niets meer gebeuren. Doe ik iets verkeerd of gaat er iets toch niet goed?

In de berichten die ik krijg is de waarde in cel a1 t/m a6 altijd uniek. Met die gegevens doe ik niets en kunnen van de macro worden uitgesloten. Het gaat er om dat de gegevens vanaf A11 worden
gebruikt. Tussen iedere reeks gegevens dit een stippellijntje met daaronder een regel met de tekst 'The transaction is processed via Switch over Service'. Die gegevens filter ik er uit voordat ik de macro laat draaien. Het zou mooi zijn als dat niet nodig is.

Het uiteindelijke resultaat zou dus moeten zijn dat vanaf regel A11 de macro start. Ik heb het bestand, zoals ik die nu heb,in het bericht toegevoegd. Ik hoop dat jullie mij verder kunnen helpen. Vast bedankt voor de moeite.
Bekijk bijlage versie 17-01-2016.xlsm