AW: Liste aus verschiedenen Register Daten
25.10.2010 14:44:26
Josef
Hallo Aleandro,
ersetze das Makro durch folgenden Code.
Sub oversight()
Dim objWB As Worksheet
Dim lngNext As Long, lngLast As Long
Dim rng As Range, rng2 As Range
On Error GoTo ErrExit
Application.ScreenUpdating = False
With Sheets("Action Plan")
.Range("A10:F" & .Rows.Count).Clear
lngNext = 10
For Each objWB In ThisWorkbook.Worksheets
If objWB.Name <> .Name Then
Set rng = objWB.Columns(1).Find(What:="2. Action Plan", LookAt:=xlWhole, LookIn:=xlValues)
If Not rng Is Nothing Then
Set rng2 = objWB.Columns(1).Find(What:="3. Issues and Risks", LookAt:=xlWhole, LookIn:=xlValues)
If rng2.Row > rng.End(xlDown).Row And rng.End(xlDown).Row > rng.Row + 1 Then
Set rng = rng.Offset(2, 0).Resize(rng.End(xlDown).Row - rng.Row - 1, 5)
rng.Copy .Cells(lngNext, 2)
With .Range(.Cells(lngNext, 1), .Cells(lngNext + rng.Rows.Count - 1, 1))
.Value = objWB.Name
.Borders(xlInsideHorizontal).Weight = xlHairline
.Borders(xlEdgeBottom).Weight = xlHairline
End With
lngNext = lngNext + rng.Rows.Count
End If
End If
End If
Next
End With
ErrExit:
Application.ScreenUpdating = True
Set rng2 = Nothing
Set rng = Nothing
Set objWB = Nothing
End Sub
Gruß Sepp