AW: Verschieben
16.04.2008 18:07:12
Erich
Hi Maxi,
hier werden die Formeln in den zu verschiebenden Zellen vor der Verschiebung
durch Werte ersetzt:
Sub kopieren5()
Dim strSuch, ii As Integer, rngF As Range, lngZ As Long, lngF As Long
Dim rngSuch(1) As Range, jj As Integer, lngSpV(1), lngSpB(1)
Dim lngZiel As Long, lngAnz As Long, rngC As Range, rngA As Range
strSuch = Split("Öl Eisen Kupfer") ' Suchbegriffe
Set rngSuch(0) = Range(Cells(5, 2), Cells(1900, 2)) ' Suchbereich 1
Set rngSuch(1) = Range(Cells(5, 7), Cells(1900, 7)) ' Suchbereich 2
lngSpV(0) = 1: lngSpB(0) = 4 ' Copy Spalten 1
lngSpV(1) = 6: lngSpB(1) = 9 ' Copy Spalten 2
lngZiel = 2000 ' Zielzeile ab
For jj = 0 To 1
lngAnz = 0
For ii = 0 To UBound(strSuch)
With rngSuch(jj)
Set rngF = .Find(What:=strSuch(ii), after:=.Cells(.Rows.Count, .Columns.Count), _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not rngF Is Nothing Then
lngZ = rngF.Row
lngF = lngZ
Do
If rngC Is Nothing Then
Set rngC = Range(Cells(lngZ, lngSpV(jj)), Cells(lngZ, lngSpB(jj)))
Else
Set rngC = Union(rngC, _
Range(Cells(lngZ, lngSpV(jj)), Cells(lngZ, lngSpB(jj))))
End If
Set rngF = .FindNext(rngF)
If rngF Is Nothing Then lngZ = lngF Else lngZ = rngF.Row
lngAnz = lngAnz + 1
Loop While lngZ > lngF
End If
End With
Next ii
For Each rngA In rngC.Areas
With rngA
.Value = .Value ' hier werden Formel durch Werte ersetzt
.Copy Cells(lngZiel + lngAnz, lngSpV(jj))
.Delete xlShiftUp
End With
Next rngA
Set rngC = Nothing
Next jj
End Sub
Ob das alles sinnvoll ist, sei dahingestellt.
Rückgängig lässt es sich jedenfalls nicht so einfach machen.
Was ist mit Formeln, die sich auf die gelöschten Zellen beziehen?
Ganz gut wäre eine Beispielmappe gewesen.
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort