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

[HSV]

Sub hsv()
Dim area As Range, c As Range
Application.ScreenUpdating = False
For Each area In Sheets(1).Columns(1).SpecialCells(2).Areas
Set c = Sheets(1).Range(Split(area.Address, ":")(0))
 If c.Row > 10 and Not Left(c, 1) = "-" Then
     Sheets(2).Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, area.Rows.Count) = Application.Transpose(area)
 End If
Next area
End Sub

 

[VenA]

@HSV,

Altijd leuk die snelheidstestjes. Zelf was ik ook wat aan het stoeien met Areas maar kreeg het niet voor elkaar. Nu denk ik te begrijpen hoe je ze kan toepassen.:thumb:

 

[HSV]

@VenA,

Oké. :thumb:
Het bestandje werkt bij jou wel?
De code van jou is erg snel voor een lus die door alle regels loopt (valt me 100% mee), maar verliest het als de gegevens wat verder naar onderen staan.
De code van Sylvester is daarin tegen weer veel sneller (erg verbaasd)l ook als de gegevens onderaan staan.
De code van mij in het voorbeeldje is het snelst, maar zal het misschien weer moeten afleggen tegen die van jullie als de gegevens verder naar boven staan, of tegen het aantal areas.

Zo zie je maar weer dat een code best snel kan zijn, maar alleen dan voor die specifieke gegevens.

 

[VenA]

@HSV,

Geen probleem met jouw bestandje. Mij viel de for each cl constructie op de ruim 1 miljoen rijen ook nog wel mee. Maar in vergelijking met een array of met de areas is het natuurlijk een zeer trage constructie. Dit wist ik natuurlijk al maar op het bestandje van de TS leek het mij niet zo'n grote beperking

 

[carlocarlo]

Het werkt perfect, dank jullie wel. Er is veel meer mogelijk dan dat ik dacht.
De gegevens die ik transponeer komen uit een kladblok ber4icht. Die selecteer ik en plak ik in het excel bestandje.
Is het ook mogelijk om alle kladblokbestanden in 1 map te zetten en ze in 1x naar een bestand te transponeren.Als voorbeeld heb ik 1 kladblok bestand toegevoegd.

 

[HSV]

Zet alle txt-bestanden in een map.
Even het bestanden pad wijzigen.

In onderstaande code staan ze in het rood.
De Map waarin de txt bestanden staan heet TXT.

Sub hsv()
Dim area As Range, t As Single, c As Range, txt
Application.ScreenUpdating = False
MsgBox Join(Split(CreateObject("wscript.shell").exec("cmd /c Dir ""[COLOR="#FF0000"]C:\users\hsv\desktop\TXT[/COLOR]\*.txt""/b").stdout.readall, vbCrLf), vbCrLf) 'ongesorteerd
 For Each txt In Split(CreateObject("wscript.shell").exec("cmd /c Dir ""[COLOR="#FF0000"]C:\users\hsv\desktop\TXT[/COLOR]\*.txt""/b").stdout.readall, vbCrLf)
   If txt <> "" Then
  With Sheets("invoer").QueryTables.Add(Connection:= _
        "TEXT;[COLOR="#FF0000"]C:\users\hsv\desktop\TXT[/COLOR]\" & txt, Destination:=Sheets("invoer").[a1])
            .TextFileParseType = xlDelimited
            .TextFileTabDelimiter = False
            .TextFileSemicolonDelimiter = True
            .TextFileCommaDelimiter = False
            .TextFileSpaceDelimiter = False
            .Refresh False
    End With
   
 
    For Each area In Sheets(1).Columns(1).SpecialCells(2).Areas
      Set c = area
      If c.Row > 10 And Not Left(Sheets(1).Cells(c.Row, 1), 1) = "-" Then
        Sheets(2).Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, area.Rows.Count) = Application.Transpose(area)
      End If
    Next area
  End If
Sheets("Invoer").Columns(1).Clear
Next txt
End Sub

 

[carlocarlo]

Beste Harry, het werk. Net 2200 tekstbestanden binnen no time in kunnen lezen. Ontzettend bedankt.

Met vriendelijke groet,
Carlo

 

[sylvester-ponte]

hallo Carlo, boven aan is een regeltje toe gevoegd.
als je er gegels tussen wil zet er dan +2 (voor 2 lege rijen) achter deze toegevoegde regel.

Sub svp()
[COLOR="#FF0000"]r = Sheets("totaal overzicht").Cells(Rows.Count, 1).End(xlUp).Row[/COLOR]
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 Sub

ps ik zie dat het al niet meer nodig is
je hebt de mooie oplossing van Harry gebruikt. :thumb:

 

[carlocarlo]

Hallo Sylvester, jij ook nog bedankt voor het meewerken aan de oplossing. Zelf had ik er nooit uit gekomen.