Hi,
nun ICH meine, du wirst wegen der vielen Sonderfälle nicht um Code herumkommen, der Zelle für Zelle prüft und kopiert.
In Etwa so:
Option Explicit
Sub TastIt()
'
Dim rngCopyFrom As Range
Dim rngCopyTo As Range
Dim rngCopyCells As Range
Dim rngStep As Range
Dim myOffRow As Long
'
'
'
On Error GoTo TastIt_Error
ActiveSheet.Unprotect
'
Set rngCopyFrom = Application.InputBox("Doppelklick in Spaltenkopf", "Quellspalte selektieren", , , , , , 8)
If rngCopyFrom.Cells.Count < Rows.Count Then Err.Raise 513
Set rngCopyTo = Application.InputBox("Doppelklick in Spaltenkopf", "Zielspalte selektieren", , , , , , 8)
If rngCopyTo.Cells.Count < Rows.Count Then Err.Raise 513
'
'
Set rngCopyCells = Range(rngCopyFrom.Cells(1), Cells(Rows.Count, rngCopyFrom.Column).End(xlUp))
'
For Each rngStep In rngCopyCells.Cells
If Cells(rngStep.Row, rngCopyTo.Column).Offset(myOffRow).Locked = True Then
'
myOffRow = myOffRow + 1
'
Do While Cells(rngStep.Row, rngCopyTo.Column).Offset(myOffRow).Locked = True
myOffRow = myOffRow + 1
Loop
End If
'
rngStep.Copy Destination:=Cells(rngStep.Row, rngCopyTo.Column).Offset(myOffRow)
'
'Debug.Print rngStep.Address
Next rngStep
'
On Error GoTo 0
'
TastIt_Error:
'------------------------------------------------------------------------------
Select Case Err.Number
Case Is = 0: 'errorless
Case Is = 513
Call MsgBox("keine ganze Spalte selektiert!", vbCritical, "Abbruch")
Case Else:
End Select
'------------------------------------------------------------------------------
ActiveSheet.Protect
End Sub
|