Hallo Daniel,
hier ist der Link zur Exceldatei:
https://www.herber.de/bbs/user/122460.xlsx
Hier ist mein Makro, an dem ich arbeite, um die Daten zu strukturieren:
Sub Makro1_Sheets_ergaenzen()
' Makro1_Sheets_ergaenzen Makro
' Direction bestimmen und auf Tabelle2 eintragen
' Logo löschen
ActiveSheet.Pictures.Delete
On Error Resume Next
Application.DisplayAlerts = False
Sheets(1).Delete
Application.DisplayAlerts = True
Sheets.Add
Sheets(2).Select
Range("A1").Select
Cells.Find(What:="Date", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Sheets(1).Range("A1").Value = ActiveCell.Value
' Activecell.entirerow.delete
Cells.Find(What:="Direction", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Sheets(1).Range("A2").Value = ActiveCell.Value
'Kopflöschen
Cells.Find(What:="crew member", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
'Range("A1:A15").Select
Dim lgacRow As Long
Dim iacCol As Integer
lgacRow = ActiveCell.Row
iacCol = ActiveCell.Column
'Range(Cells(1, 1), Cells(lgacRow, iacCol)).EntireRow.Delete Shift:=xlUp
'Sheets(2).Range(Cells(1, 1), (Cells(ActiveCell))).EntireRow.Delete Shift:=xlUp
' Activecell.entirerow.delete
'Hotel Pullman ersetzen
Cells.Replace What:="Pullman Fontana", Replacement:="Pullman_Fontana", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
False, ReplaceFormat:=False
' Hotel Maritim Hotel ersetzen
Cells.Replace What:="Maritim Hotel STR", Replacement:="Maritim_Hotel_STR", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
False, ReplaceFormat:=False
' Hotel NH Hotel Airport ersetzen
Cells.Replace What:="NH Hotel Airport STR", Replacement:="NH_Hotel_Airport_STR", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
False, ReplaceFormat:=False
'Hotel Mercure Airport/Messe ersetzen
Cells.Replace What:="Mercure Airport/Messe STR", Replacement:="Mercure_Airport/Messe_STR", _
_
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
False, ReplaceFormat:=False
'Volmoeller Strasse 5 ersetzen
Cells.Replace What:="Vollmoeller Strasse 5", Replacement:="", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
False, ReplaceFormat:=False
'70563 Stuttgart ersetzen
Cells.Replace What:="70563 Stuttgart", Replacement:="", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
False, ReplaceFormat:=False
'Seidenstrasse 34 ersetzen
Cells.Replace What:="Seidenstrasse 34", Replacement:="", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
False, ReplaceFormat:=False
'70174 Stuttgart ersetzen
Cells.Replace What:="70174 Stuttgart", Replacement:="", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
False, ReplaceFormat:=False
'Bonlaender Hauptstrasse 145 ersetzen
Cells.Replace What:="Bonlaender Hauptstrasse 145", Replacement:="", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
False, ReplaceFormat:=False
'Bonlaender Hauptstrasse ersetzen
Cells.Replace What:="Bonlaender Hauptstrasse", Replacement:="", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
False, ReplaceFormat:=False
'70794 Stuttgart ersetzen
Cells.Replace What:="70794 Stuttgart", Replacement:="", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
False, ReplaceFormat:=False
'Eichwiesenring 1/1 ersetzen
Cells.Replace What:="Eichwiesenring 1/1", Replacement:="", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
False, ReplaceFormat:=False
'70563 Stuttgart ersetzen
Cells.Replace What:="70563 Stuttgart", Replacement:="", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
False, ReplaceFormat:=False
'145 Stuttgart ersetzen
Cells.Replace What:="145", Replacement:="", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
False, ReplaceFormat:=False
' Sheets(2).Select
'Range("A16").Select
' Range("A16").Value = GLÄTTEN(TEIL(A1;MAX(1;SUCHEN(")";A1)-2);99))
'leere Zeilen löschen
Sheets(2).Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
'Dim lgCount As Long
'Dim lgLetzte As Long
'With Sheets(2)
'lgLetzte = .UsedRange.SpecialCells(xlCellTypeLastCell).Row
'For lgCount = lgLetzte To 1 Step -1
'If Not IsEmpty(.Cells(lgCount, 1)) And .Cells(lgCount, 1).Value = "" _
'Or .Cells(lgCount, 1).Value = "" Then
'.Cells(lgCount, 1).EntireRow.Delete Shift:=xlUp
'End If
'Next
'End With
'Dim lgCount As Long
'Dim lgLetzte As Long
'lgLetzte = Sheets(2).UsedRange.SpecialCells(xlCellTypeLastCell).Row
'Sheets(2).Activate
'For lgCount = lgLetzte To 1 Step -1
'If Cells(lgCount, 1).Value = "" Then
'Cells(lgCount, 1).EntireRow.Delete Shift:=xlUp
'End If
'Next
'Zeilenumbruch SPalte A entfernen
Dim lgCount As Long
Dim lgLetzte As Long
lgLetzte = Sheets(2).UsedRange.SpecialCells(xlCellTypeLastCell).Row
Sheets(2).Activate
For lgCount = lgLetzte To 1 Step -1
Sheets(2).Cells(lgCount, 2).FormulaR1C1 = "=IF(SUBSTITUTE(RC1,CHAR(10),"""")="""",0,ROW())"
Next
Sheets(2).Columns("A:A").Select
Selection.ClearFormats
With Sheets(2).UsedRange
With .Columns(.Columns.Count + 1)
.FormulaR1C1 = "=IF(RC1="""",0,Row())"
.Cells(1, 1).Value = 0
.EntireRow.RemoveDuplicates .Column, xlNo
.ClearContents
End With
End With
'lgLetzte = Sheets(2).UsedRange.SpecialCells(xlCellTypeLastCell).Row
'For lgCount = lgLetzte To 1 Step -1
'If Not IsEmpty(Cells(lgCount, 1)) And Cells(lgCount, 1).Value = ""
'If Cells(lgCount, 1).Value = "" Then
'Cells(lgCount, 1).EntireRow.Delete Shift:=xlUp
'End If
'Next
'For next Schleife aufbauen um Formel zu kopieren
'Dim lgCounti As Long
'Dim lgLetztei As Long
' lgLetztei = Range("A65536").End(xlUp).Row
'lgLetztei = Sheets(2).UsedRange.SpecialCells(xlCellTypeLastCell).Row
'For lgCounti = lgLetztei To 1 Step -1
'Sheets(2).Activate
'Sheets(2).Cells(lgCounti, 13).FormulaR1C1 = "=LEFT(RC[-12],SEARCH("")"",RC[-12])-2) _
'Next
'If isNotEmpty(Cells(lgCount, 1)) Then
'Sheets(1).(Cells(lgCount,1)).FormulaR1C1lokal = "=Links(A1;Suchen(")";A1)-2)
' End If
'Kopf löschen
' Cells.Find(What:="crew member", After:=ActiveCell, LookIn:=xlFormulas, _
'LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
'MatchCase:=False, SearchFormat:=False).Activate
'ActiveCell.Select
'Rows("1:9").Select
' Range("A9").Activate
'Selection.Delete Shift:=xlUp
'Fuellzeilen loeschen
Cells.Find(What:="Page", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
ActiveCell.EntireRow.Delete
'hotelpickup loeschen
Cells.Find(What:="hotel pick up next", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
ActiveCell.EntireRow.Delete
'Anzahl der verwendeten Zeilen bestimmen im Sheet
Dim Anzahlzeilen As Integer
Anzahlzeilen = Sheets(2).Range("A65535").End(xlUp).Row
Range("D2").Value = Anzahlzeilen
'For next Schleife mit Formeln
'Zellen ohne _ loeschen
'Dim b As Integer
'Const SB As String = "_"
'Const ST As String = ")"
'Dim t As Integer
'For b = Anzahlzeilen To 1 Step -1
'If InStr(Cells(Anzahlzeilen, 1), SB) > 0 = False Then
'And if Instr(Cells(Anzahlzeilen,1), ST SB Then
't = t + 1
'Cells(Anzahlzeilen, 1).EntireRow.Delete
'End If
'Anzahlzeilen = Anzahlzeilen - 1
'Range("D3").Value = Anzahlzeilen
' Next b
'Zellen ohne _ loeschen
Sub Makro2_Personen_sortieren()
' Range("I1").Select
'ActiveCell.FormulaR1C1 = _
"=IF(ISNUMBER(SEARCH(""1)"",RC[-7])),""OK"",""Nicht OK"")"
'Range("I2").Select
'If Activecell.FormulaR1C1="=IF(ISNUMBER(SEARCH(""1)"",RC[-7]))=true then
'Const AB As String = "1)"
'If InStr(Cells(Anzahlzeilen3, 2), AB) 0 = True Then
Cells(c, 2).Select
ActiveCell.Offset(0, 1).Value = ActiveCell.Value
'End If
ElseIf InStr(Cells(c, 2), AC) > 0 = True Then
Cells(c, 2).Select
ActiveCell.Offset(-1, 2).Value = ActiveCell.Value
'End If
ElseIf InStr(Cells(c, 2), AD) > 0 = True Then
Cells(c, 2).Select
ActiveCell.Offset(-2, 3).Value = ActiveCell.Value
'End If
ElseIf InStr(Cells(c, 2), AE) > 0 = True Then
Cells(c, 2).Select
ActiveCell.Offset(-3, 4).Value = ActiveCell.Value
'End If
ElseIf InStr(Cells(c, 2), AE) > 0 = True Then
Cells(c, 2).Select
ActiveCell.Offset(-4, 5).Value = ActiveCell.Value
'End If
ElseIf InStr(Cells(c, 2), AE) > 0 = True Then
Cells(c, 2).Select
ActiveCell.Offset(-5, 6).Value = ActiveCell.Value
' End If
ElseIf Cells(c, 2).Value = "#WERT!" Then
ActiveCell.EntireRow.Delete
End If
'End If
'End If
' End If
' End If
' End If
'p = p - 1
Next c
End Sub