VBA-Lösung
19.03.2018 00:06:58
KlausF
Hallo Matze,
kannst ja mal probieren:
Sub DatenAufteilen()
'Sheet duplizieren
ThisWorkbook.Worksheets("Tabellenblatt B").Copy After:=ThisWorkbook.Sheets(Sheets.Count)
ActiveSheet.Name = "TEMP"
Dim rng As Range
Dim searchCode As String
Dim searchCol As Integer
Dim lastRow As Long, i As Long, a As Long
lastRow = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
Application.ScreenUpdating = False
'Verbundzellen aufheben
ActiveSheet.UsedRange.MergeCells = False
'leere Zeilen loeschen
On Error Resume Next
Range("A1", Range("A" & lastRow).End(xlUp)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
'Zeilen mit "Analyte" und "Series" loeschen
For i = lastRow To 1 Step -1
If InStr(Range("A" & i), "Analyte") > 0 Or InStr(Range("A" & i), "Series") > 0 Then
Rows(i).EntireRow.Delete
End If
Next i
'Leere Zeile einsetzen + 'Kopf kopieren
Range("A1").EntireRow.Insert
Worksheets("Tabellenblatt A").Range("B1:AC1").Copy Range("AA1")
'Code-Bloecke bestimmen
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
On Error Resume Next
For i = lastRow To 2 Step -1
If InStr(Range("A" & i), "Code") > 0 Then
'Spalten aufteilen
For a = 2 To Range("AA" & i).End(xlToLeft).Column
searchCode = Cells(i, a)
searchCol = WorksheetFunction.Match(searchCode, Rows(1), 0)
If searchCol > 0 Then
Range(Cells(i, a), Cells(lastRow + 1, a)).Copy Cells(i, searchCol)
End If
Next a
lastRow = i - 1
End If
Next i
On Error GoTo 0
'Zeilen mit "Code" loeschen
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i = lastRow To 1 Step -1
If InStr(Range("A" & i), "Code") > 0 Then
Rows(i).EntireRow.Delete
End If
Next i
'Spalten loeschen
Columns("B:Z").Delete
'Sortieren
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
Range("A2:AC" & lastRow).Sort _
Key1:=ActiveSheet.Range("A2"), Order1:=xlAscending, Header:=xlNo
'Daten verdichten
For i = lastRow To 2 Step -1
If Range("A" & i) = Range("A" & i - 1) Then
Range("A" & i & ":AC" & i).Copy
Range("A" & i - 1).PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=True, _
Transpose:=False
Rows(i).EntireRow.Delete
End If
Next i
'Kopieren nach Tabellenblatt A und leere Zellen = Gelb
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
Range("A2:AC" & lastRow).Copy
With Worksheets("Tabellenblatt A")
.Select
.Range("A2").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
.Columns("A:AC").AutoFit
.Range("A1").Select
For Each rng In .Range("A2:AC" & lastRow)
If IsEmpty(rng) Then rng.Interior.ColorIndex = 6
Next rng
End With
Application.CutCopyMode = False
Application.DisplayAlerts = False
Worksheets("TEMP").Delete
Application.DisplayAlerts = True
Set rng = Nothing
End Sub
https://www.herber.de/bbs/user/120511.xls
Passt es?
Gruß
Klaus
PS. Achte auf die Tabellennamen. Du hast "Tabelleblatt A" statt "Tabellenblatt A" geschrieben
Ist im Code korrigiert