AW: Verknüpfungen durch Absolutwerte ersetzen
18.12.2003 12:53:22
Michael Brueggemann
Hallo Rainer,
dieser Code (in "Diese Arbeitsmappe" abgelegt) sollte die Loesung fuer Dein "Problem" sein:
Option Explicit
Option Base 1
Private Sub Workbook_Open()
' Laeuft bei oeffnen der Arbeitsmappe automatisch ab
Dim i, intLineFrom, intLineTo As Integer
Dim intRowFrom, intRowTo, intColFrom, intColTo As Integer
Dim rngActiveSelection, rngFoundIn As Range
' Bildschirmaktualisierung abschalten
Application.ScreenUpdating = False
' gewuenschtes Worksheet aktivieren und aktive Zelle speichern
ThisWorkbook.Sheets(1).Activate
Set rngActiveSelection = ActiveCell
With ActiveSheet
' erste und letzte Zeile und Spalte des zu bearbeitenden Bereiches festlegen
' HIER DIE EIGENE FESTLEGUNG TREFFEN
intRowFrom = 1 ' von Zeile 1
intRowTo = .UsedRange.Rows.Count ' bis zur letzten benutzten Zeile
intColFrom = 1 ' von Spalte 1
intColTo = .UsedRange.Columns.Count ' bis zur letzten benutzten Spalte
' zu untersuchenden Bereich festlegen
Set rngFoundIn = .Range(Cells(intRowFrom, intColFrom), Cells(intRowTo, intColTo))
' Bezug in festgelegtem Bereich finden
Set rngFoundIn = rngFoundIn.Find("[", , xlFormulas)
' wenn Bezug gefunden, dann ...
If Not rngFoundIn Is Nothing Then
' Startzeile festlegen
i = rngFoundIn.Row
' Arbeitsblatt so lange durchlaufen, bis Ende erreicht oder
' Summe der Werte der Zeile 0 ergibt (Bedingung ggf. anpassen)
Do While i <= intRowTo And _
WorksheetFunction.Sum(Range(.Cells(i, intColFrom), .Cells(i, intColTo))) <> 0
' Zeilenzaehler erhoehen
i = i + 1
Loop
' wenn etwas zu tun ist, da die erste zu bearbeitende Zeile
' nicht die Summe 0 enthaelt, dann ...
If i > rngFoundIn.Row Then
' zu ersetzenden Bereich kopieren
.Range(Cells(rngFoundIn.Row, intColFrom), Cells(i - 1, intColTo)).Copy
' Inhalte des kopierten Bereiches an der gleichen Stelle einfuegen
Range(Cells(rngFoundIn.Row, intColFrom), Cells(i - 1, intColTo)).PasteSpecial (xlPasteValues)
' Kopiermarkierung aufheben
Application.CutCopyMode = False
' vorher aktivierte Zelle reaktivieren
rngActiveSelection.Select
End If ' If i > rngFoundIn.Row
End If ' If Not rngFoundIn Is Nothing
End With ' With ActiveSheet
' Bildschirmaktualisierung wieder einschalten
Application.ScreenUpdating = True
End Sub
CIAO
Michael