AW: Daten sortieren und darstellen
24.05.2024 18:11:25
Dome der Unwissende
ich habe mal chtgpt gefragt und sie hat mir bis jetzt mal das zusammengebaut.
Dim ws As Worksheet
Dim newWs As Worksheet
Dim dataRange As Range
Dim uniqueExercises As Collection
Dim cell As Range
Dim exercise As Variant
Dim cleanExerciseTitle As String
Dim lastRow As Long
' Set the worksheet and data range
Set ws = ThisWorkbook.Sheets(1) ' Assuming data is in the first sheet
Set dataRange = ws.Range("A1").CurrentRegion ' Assuming data starts at A1
' Add a new column for cleaned exercise titles
ws.Cells(1, dataRange.Columns.Count + 1).Value = "clean_exercise_title"
' Clean the exercise titles and make sure they are valid sheet names
For Each cell In dataRange.Columns(5).Cells ' Assuming exercise_title is the fifth column
If cell.Row > 1 Then ' Skip the header
cleanExerciseTitle = UCase(Trim(WorksheetFunction.Clean(cell.Value)))
cleanExerciseTitle = Replace(cleanExerciseTitle, " ", "_")
cleanExerciseTitle = Replace(cleanExerciseTitle, ":", "")
cleanExerciseTitle = Replace(cleanExerciseTitle, "\", "")
cleanExerciseTitle = Replace(cleanExerciseTitle, "/", "")
cleanExerciseTitle = Replace(cleanExerciseTitle, "[", "")
cleanExerciseTitle = Replace(cleanExerciseTitle, "]", "")
cleanExerciseTitle = Replace(cleanExerciseTitle, "*", "")
cleanExerciseTitle = Replace(cleanExerciseTitle, "?", "")
cleanExerciseTitle = Replace(cleanExerciseTitle, "'", "")
If Len(cleanExerciseTitle) > 31 Then ' Ensure name length does not exceed 31 characters
cleanExerciseTitle = Left(cleanExerciseTitle, 31)
End If
ws.Cells(cell.Row, dataRange.Columns.Count + 1).Value = cleanExerciseTitle
End If
Next cell
' Collect unique cleaned exercise titles
Set uniqueExercises = New Collection
On Error Resume Next
For Each cell In dataRange.Columns(dataRange.Columns.Count + 1).Cells ' Last column with cleaned titles
If cell.Row > 1 Then ' Skip the header
uniqueExercises.Add cell.Value, CStr(cell.Value)
End If
Next cell
On Error GoTo 0
' Copy data into separate sheets
For Each exercise In uniqueExercises
Set newWs = Nothing
On Error Resume Next
Set newWs = ThisWorkbook.Sheets(exercise)
On Error GoTo 0
If newWs Is Nothing Then
Set newWs = ThisWorkbook.Sheets.Add
newWs.Name = exercise
' Copy header row
dataRange.Rows(1).Copy Destination:=newWs.Range("A1")
End If
' Filter and copy data
dataRange.AutoFilter Field:=dataRange.Columns.Count, Criteria1:=exercise
If Application.WorksheetFunction.Subtotal(3, dataRange.Columns(1)) > 1 Then
lastRow = newWs.Cells(Rows.Count, 1).End(xlUp).Row
dataRange.Offset(1, 0).Resize(dataRange.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy Destination:=newWs.Range("A" & lastRow + 1)
End If
ws.AutoFilterMode = False
Next exercise
End Sub
damit werden mir zumindest schon mal arbeitsmappen mit den Übungsnamen erstellt. Leider werden diese aber nicht gefüllt mit den Daten.
gruss Dome
ps. ich habe die datei hochgeladen finde diese aber nicht bzw weiss nicht genau wo ich diese suchen soll