Ecxel Listenform in Spaltform umverteilen

Hallo
Ich habe folgendes Problem. Beim Messen von Motorlagern gibt die Messmaschine eine Exceltabelle aus in der mehrere Datenpakete mit Messergebnissen in eine Ecxeltabelle geschrieben werden.
Es werden immer Spalten in unterschiedlicher Zellenlänge gefüllt z.b. Spalte A bis F komplet mit Zahlen bis Zelle 654 dann kommen 2 Leerzellen und das nächste Datenpaket wird geschrieben z.b. Spalte A bis F von Zeile 657 bis 1450. So werden mehrere Datenblöcke untereinander in eine Exceltabelle geschrieben.
Mein Problem ist das ich diese Einzelblöcke erkennen muß und die einzelnen Blöcke dann nebeneinander in eine Excelblatt einfügen möchte.
Ich habe zwei Excel Dateien als Beispiel zum Server geladen.
https://www.herber.de/bbs/user/3488.xls

Die Datei https://www.herber.de/bbs/user/3489.xls wurde aus Datenschutzgründen gelöscht

Die eingefärbten Bereiche im Datenblatt specimen bezeichnen die Bereiche die ich nebeneinander im Blatt Tabelle 1 angeordnet haben möchte. Die Listen im Blatt specimen können noch länger oder aber auch kürzer sein. Die Freiräume in der Liste Blatt specimen bleiben aber immer gleich.
Vielen Dank

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Umschaufeln() Dim wb As Workbook Dim ws As Worksheet Dim wsErg As Worksheet Dim ZielSpalte As Long Schlüsselwort(1) = "Static Deflection" Schlüsselwort(2) = "Calculated Stiffness" Schlüsselwort(3) = "Dynamic Characterization" Set wb = ThisWorkbook Set wsSp = wb.Worksheets("specimen") Application.DisplayAlerts = False For Each ws In wb.Worksheets If ws.Name = "Ergebnis" Then ws.Delete Next ws Application.DisplayAlerts = True Set wsErg = wb.Worksheets.Add wsErg.Name = "Ergebnis" EndZeile = 0 ZielSpalte = 1 Do While WeitererBlockVorhanden(Start:=EndZeile + 1) ' Block umkopieren wsSp.Range(wsSp.Cells(AnfZeile, 1), _ wsSp.Cells(EndZeile, SpaltenAnzahl)).Copy _ Destination:=wsErg.Cells(1, ZielSpalte) ZielSpalte = ZielSpalte + SpaltenAnzahl + 1 Loop wsErg.Cells.Interior.ColorIndex = -4142 End Sub

Function WeitererBlockVorhanden(Start As Long) As Boolean Dim BlockTyp As Long Dim i As Long Dim rng As Range Dim zeile As Long For zeile = Start To wsSp.Rows.Count For i = 1 To 3 If wsSp.Cells(zeile, 1) = Schlüsselwort(i) Then WeitererBlockVorhanden = True AnfZeile = zeile BlockTyp = i Exit For End If Next i If WeitererBlockVorhanden Then Exit For Next zeile ' Blockgröße bestimmen If WeitererBlockVorhanden Then Select Case BlockTyp Case 2 EndZeile = AnfZeile + 12 SpaltenAnzahl = 5 Case 1, 3 Set rng = wsSp.Cells(AnfZeile + 6, 1).CurrentRegion EndZeile = rng.Rows(rng.Rows.Count).Row If BlockTyp = 1 Then SpaltenAnzahl = 9 Else SpaltenAnzahl = 12 End If End Select End If End Function

Hallo Karl,
habe mal eine Lösung kreiert. Bitte die nachfolgende Makros in ein neues Modul kopieren und dann die Datei mit den Blättern "spicemen" und "Tabelle1" öffnen.
Dann das Makro "Kopieren" ausführen. Bei mir hat es mit deinen Beispieldaten einwandfrei funktioniert.


Public Sub Kopieren()
Dim srcRng      As Range
Dim stRow       As Long
Dim EndRow      As Long
Dim spCol       As Long
Dim isLimiter   As Boolean
Dim saveRow     As Long
Dim eRow        As Long
With ActiveWorkbook.Sheets("specimen")
EndRow = .Cells(65500, 1).End(xlUp).Row
saveRow = 1
For stRow = 1 To EndRow
Set srcRng = .Range("A" & stRow & ":" & "A" & EndRow).Find("", _
After:=.Cells(stRow, 1), LookIn:=xlValues, _
lookat:=xlWhole, searchorder:=xlByRows)
If srcRng Is Nothing Then
Exit For
End If
isLimiter = True
stRow = srcRng.Row
For spCol = 1 To 3
If .Cells(stRow + spCol - 1, 1) <> "" Or _
.Cells(stRow + spCol - 1, 255).End(xlToLeft).Column > 1 Then
If spCol < 3 Then
isLimiter = False
End If
Exit For
End If
If spCol = 3 Then
isLimiter = False
End If
Next spCol
'Sonderfall: Vor der Zelleninschrift "Calculated" stehen DREI
'Leerzeilen!!!!
If Left(UCase(.Cells(stRow + 3, 1).Value), 10) = "CALCULATED" Then
isLimiter = True
eRow = 3
Else
eRow = 2
End If
If isLimiter Then
CopyArea saveRow, stRow
saveRow = eRow + stRow
End If
Next stRow
CopyArea saveRow, EndRow
End With
End Sub
Private Sub CopyArea(StartRow As Long, EndRow As Long)
Dim endCol      As Long
Dim tarEndCol   As Long
Dim sh          As Worksheet
If StartRow > EndRow Then
Exit Sub
End If
With ActiveWorkbook.Sheets("specimen")
Set sh = ActiveWorkbook.Sheets("Tabelle1")
endCol = GetLastColumn(.Range("A1:A10"))
tarEndCol = GetLastColumn(sh.Range("A1:A10"))
If tarEndCol > 1 Then
tarEndCol = tarEndCol + 2
End If
.Range(.Cells(StartRow, 1), .Cells(EndRow, endCol)).Copy sh.Cells(1, tarEndCol)
End With
End Sub
Private Function GetLastColumn(SRange As Range) As Long
Dim i       As Integer
GetLastColumn = 1
For i = 1 To 10
If i > SRange.Count Then
Exit Function
End If
If GetLastColumn < SRange.Cells(i, 255).End(xlToLeft).Column Then
GetLastColumn = SRange.Cells(i, 255).End(xlToLeft).Column
End If
Next i
End Function

Beliebteste Forumthreads (12 Monate)

Ecxel Listenform in Spaltform umverteilen

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread