Hallo,
ich habe jetzt auf Activeworkbook erweiteret. Leider bekomme ich eine Fehlermeldung.
Hier einmal der VBA Code:
Option Explicit
Sub Start()
Dim rng As Range, rngNext As Range, rngCopyRange As Range, rngTmp As Range
Dim oWS As Worksheet
Dim NextRow&, n&
Dim nCol
Dim strName$
On Error GoTo ErrorHandler:
Call Events(False)
Set rng = FindMA(ActiveWorkbook.Worksheet("Page 1").UsedRange)
If Not rng Is Nothing Then
For Each rngTmp In rng.Cells
strName = FindName(rngTmp)
If strName "" Then
Call FindTabelle(strName, True)
End If
Next
For Each rngTmp In rng.Cells
Set rngNext = FindEnde(ActiveWorkbook.Worksheet("Page 1").UsedRange, rngTmp)
If Not rngNext Is Nothing Then
Set rngCopyRange = ActiveWorkbook.Worksheet("Page 1").Range(rngTmp, rngNext). _
EntireRow
strName = FindName(rngTmp)
If strName "" Then
Set oWS = FindTabelle(strName)
If Not oWS Is Nothing Then
With rngCopyRange
NextRow = oWS.Cells(oWS.Rows.Count, 1).End(xlUp).Row
If NextRow > 1 Then NextRow = NextRow + 3
rngCopyRange.Copy
oWS.Cells(NextRow, 1).PasteSpecial Paste:=xlPasteColumnWidths
rngCopyRange.Copy oWS.Cells(NextRow, 1)
With oWS.Cells(NextRow, 1).Resize(rngCopyRange.Rows.Count, rngCopyRange. _
Columns.Count)
For n = 4 To 7
nCol = Application.Match("Abw.", .Rows(n), 0)
If IsNumeric(nCol) Then Exit For
Next
If IsNumeric(nCol) Then
If NextRow 0 Then
MsgBox Err.Description, vbCritical, "Fehler: " & Err.Number
Else
MsgBox "Tabellen wurden erstellt!", vbInformation
End If
End Sub
Function FindMA(rngBereich As Range) As Range
Dim rng As Range, sErste$
On Error Resume Next
Set rng = rngBereich.Find(What:="Stundenliste", After:=rngBereich.Cells(rngBereich.Rows.Count, _
rngBereich.Columns.Count), _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If rng Is Nothing Then Exit Function
Set FindMA = rng
sErste = rng.Address
Set rng = rngBereich.FindNext(rng)
Do While sErste rng.Address
Set FindMA = Union(FindMA, rng)
Set rng = rngBereich.FindNext(rng)
Loop
End Function
Function FindEnde(rngBereich As Range, AfterRng As Range) As Range
On Error Resume Next
Set FindEnde = rngBereich.Find(What:="Unterschrift", After:=AfterRng, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not FindEnde Is Nothing Then
If FindEnde.Row
Function FindTabelle(strName$, Optional booDelete As Boolean) As Worksheet
On Error Resume Next
With ThisWorkbook
Set FindTabelle = ThisWorkbook.ActiveWorkbook.Worksheet(strName)
If FindTabelle Is Nothing Then
Set FindTabelle = .ActiveWorkbook.Worksheet.Add(After:=.Sheets(.Sheets.Count))
FindTabelle.Name = strName
ElseIf booDelete Then
FindTabelle.Delete
Set FindTabelle = .ActiveWorkbook.Worksheet.Add(After:=.Sheets(.Sheets.Count))
FindTabelle.Name = strName
End If
End With
Err.Clear
End Function
Function FindName(ByVal AfterRng As Range)
Dim n&
Const KillZeichen$ = ":\/?*[]=!"
With AfterRng.EntireRow.Resize(10)
For n = 1 To .Rows.Count
If .Cells(n, 1).Value = "Mitarbeiter" Then
FindName = .Rows(n).Cells(1, .Rows(n).Cells(1, 1).MergeArea.Columns.Count + 1).Value
End If
Next
End With
For n = 1 To Len(KillZeichen)
FindName = Replace(FindName, Mid(KillZeichen, n, 1), " ")
Next
FindName = Trim$(FindName)
End Function
Sub Events(booSchalter As Boolean)
With Application
.ScreenUpdating = booSchalter
.DisplayAlerts = booSchalter
.EnableEvents = booSchalter
.Calculation = IIf(booSchalter, xlCalculationAutomatic, xlCalculationManual)
End With
End Sub
Laufzeitfehler 438
Objekt unterstütz die Methode oder Eigenschaft nicht.
Kann jemand helfen ?
Gruß Ingo