AW: zum zweiten Punkt
04.03.2005 19:59:23
Luc
Na das ist ja schön Lorenz,
ich dachte schon, hier wär's für dich auch schon wieder vorbei. Ich überlasse dir hier die Beta-Version meiner Ersatzfunktion für INDIREKT. Ich hatte ja angedeutet, dass ich schon mal sowas für meine Zwecke geschrieben hatte, die wurde aber mit deinem Problem nicht fertig. Die neue schafft das und noch ein bisschen mehr, allerdings dürfte sie Pfadangaben und Mehrfachauswahlen nicht beherrschen, was die andere gekonnt hätte. Aber ich hab sie inzwischen auch auf diese nichtzusammenhängenden (Mehrfachauswahl-)Bereiche erweitert, sie braucht dann aber noch andere selbstgeschriebene Funktionen und das geht dann schon etwas zu weit. Aber für deine Zwecke (getestet) reicht sie ja so wie folgt:
Function TinRange(ByVal BezText As Variant, Optional ByVal unsichtBl As Variant) As Variant
' Ersatz für INDIREKT() - Umwandlung eines (Bezugs auf einen) Bezugstext in einen Bereichsbezug -
' nur für Einfachauswahl zushängd gleicher Zellbereiche mehrerer aufeinanderff ArbBl nur einer Datei
' unter Auslassung/Einbeziehung (unsichtBl=fehlt|0/1) in der ArbBlFolge auftretd versteckter Blätter
' Autor: L.Schuller - Version 1.2 beta - Erstpublikation: 20050304 auf Herbers-Excel-Server
Dim bz(2) As String, zz As String, i As Integer, n As Integer, mz As Boolean, _
j As Long, k As Long, m As Long, x As Worksheet, y() As Variant, z() As Variant
Const SZ = ":\[]'!" 'mögl SonderZ in Zellbezügen
On Error GoTo fx
If IsError(BezText) Then Exit Function
If IsMissing(unsichtBl) Then
unsichtBl = False
Else: unsichtBl = CBool(unsichtBl)
End If
If IsEmpty(BezText) Then Exit Function
If InStr(BezText, Right(SZ, 1)) Then
bz(0) = Left(BezText, InStr(BezText, Right(SZ, 1)) - 1)
End If
bz(0) = WorksheetFunction.Substitute(bz(0), Mid(SZ, 5, 1), "") 'Entfernen störend 'Begrenzer'
zz = Mid(BezText, InStr(BezText, Right(SZ, 1)) + 1)
mz = InStr(zz, Left(SZ, 1))
With ActiveWorkbook
If bz(0) = "" Then
Set TinRange = ActiveSheet.Range(zz)
ElseIf InStr(bz(0), Left(SZ, 1)) > 0 Then
bz(1) = Left(bz(0), InStr(bz(0), Left(SZ, 1)) - 1)
bz(2) = Mid(bz(0), InStr(bz(0), Left(SZ, 1)) + 1)
n = .Sheets(bz(2)).Index - .Sheets(bz(1)).Index
m = Range(zz).Cells.Count
If mz Then
n = (n + 1) * m - 1
End If
ReDim y(n) As Variant
For Each x In .Sheets
If x.Index > .Sheets(bz(2)).Index Then Exit For
If x.Index >= .Sheets(bz(1)).Index Then
If mz Then 'ZellErfassung Bereichsbezüge
For j = 0 To m - 1
If x.Visible = xlSheetVisible Or unsichtBl Then
Set y(i * m + j - k) = x.Range(zz).Cells(j + 1)
Else: k = k + 1 'Zählen entfalld Zellen
End If
Next j
ElseIf x.Visible = xlSheetVisible Or unsichtBl Then 'ZellErfassung Einzelzellen
Set y(i - k) = x.Range(zz)
Else: k = k + 1 'Zählen entfalld Zellen
End If
i = i + 1
End If
Next x
ReDim z(n - k) As Variant
For i = 0 To n - k 'Erstellung Vektor ohne leere Endzellen
z(i) = y(i)
Next i
TinRange = Array(z)
Else
TinRange = .Sheets(bz(0)).Range(zz)
End If
End With
Exit Function
fx: Rem Fehlerbehandlung
TinRange = "F" & Err.Number & ": " & Err.Description
End Function
Weiter viel Erfolg und schönes WE
Luc