AW: Gültigkeitsprüfung von Tab zu Tab kopieren?
08.02.2006 19:31:26
Tab
Guten Abend Reinhard,
nachstehend der Code (die Stelle, wo die Zellinhalte reinkopiert werden, habe ich mit "Dies sind die Zellen .." gekennzeichnet.
Sub Seite_kopieren_aktuelle_Stellungnahme_BÜ() '04.02.06 - 17:11
Sheets("Stellungnahme BÜ").Select
Sheets("Stellungnahme BÜ").Move Before:=Sheets(1)
Sheets("Beispiel Stellungnahme BÜ").Select
Sheets("Beispiel Stellungnahme BÜ").Move After:=Sheets(5)
Sheets("Nachtragsübersicht").Select
ActiveSheet.Unprotect Password:="Passwort"
If MsgBox("Sind Sie sicher, dass Sie die Daten aus 'Stellungnahme BÜ' übernehmen wollen?", vbYesNo, "Hinweis beachten!") = vbNo Then Exit Sub
If MsgBox("Sind Sie wirklich sicher?", vbYesNo, "Sicherheitsabfrage") = vbNo Then Exit Sub
Range("B7:D8").Select
ActiveCell.FormulaR1C1 = _
"=IF(R[23]C[29]<R[8]C[29],R[4]C[28],IF(R[23]C[29]=R[8]C[29],""Ergebnis:"",))"
Range("AE11").Select
ActiveCell.FormulaR1C1 = "1"
Range("Q9").Select
ActiveCell.FormulaR1C1 = "? %"
Range("B13:AB13").Select
Selection.Copy
ActiveWindow.SmallScroll ToRight:=-12
Range("B14:AB213").Select
ActiveWindow.ScrollRow = 12
ActiveWindow.SmallScroll ToRight:=-14
ActiveSheet.Paste
Range("B14").Select
ActiveCell.FormulaR1C1 = 1
Application.CutCopyMode = False
Application.ScreenUpdating = False
Sheets("Nachtragsübersicht").Range(Sheets("Nachtragsübersicht").Cells(14, 3), Sheets("Nachtragsübersicht").Cells(65535, 8)).ClearContents
'cells(13, 3) 13 = Zeilennummer, 3 = Spalte C
nRow = 14 ' = Startzeile
calcMode = Application.Calculation
Application.Calculation = xlCalculationManual
For i = 12 To Sheets("Nachtragsübersicht").UsedRange.Rows.Count
If Sheets("Stellungnahme BÜ").Cells(i, 2).Value <> "" Then ' übetragen
Sheets("Nachtragsübersicht").Cells(nRow, 3).Value = Sheets("Stellungnahme BÜ").Cells(i, 2).Value
Sheets("Nachtragsübersicht").Cells(nRow, 4).Value = Sheets("Stellungnahme BÜ").Cells(i, 3).Value
Sheets("Nachtragsübersicht").Cells(nRow, 5).Value = Sheets("Stellungnahme BÜ").Cells(i, 4).Value
Sheets("Nachtragsübersicht").Cells(nRow, 6).Value = Sheets("Stellungnahme BÜ").Cells(i, 5).Value
Sheets("Nachtragsübersicht").Cells(nRow, 7).Value = Sheets("Stellungnahme BÜ").Cells(i, 6).Value
Sheets("Nachtragsübersicht").Cells(nRow, 8).Value = Sheets("Stellungnahme BÜ").Cells(i, 7).Value
Sheets("Nachtragsübersicht").Cells(nRow, 9).Value = Sheets("Stellungnahme BÜ").Cells(i, 8).Value
Sheets("Nachtragsübersicht").Cells(nRow, 20).Value = Sheets("Stellungnahme BÜ").Cells(i + 1, 11).Value 'Dies sind die Zellen wo reinkopiert werden soll
nRow = nRow + 1
End If
Next i
Application.ScreenUpdating = True
Application.Calculation = calcMode
Dim loLetzte As Long
With Worksheets("Nachtragsübersicht")
If IsEmpty(Cells(65536, 3)) Then
loLetzte = .Cells(Rows.Count, 3).End(xlUp).Row
End If
.Range(Cells(11, 34), Cells(25, 54)).Copy Destination:=.Cells(loLetzte + 1, 2) ' korrigiert von HansH.
Cells.Select
Selection.Locked = True
Selection.FormulaHidden = True
ActiveWindow.SmallScroll ToRight:=9
Range("Q9").Select
Selection.Locked = False
Selection.FormulaHidden = True
Range("M14:T213").Select
Selection.Locked = False
Selection.FormulaHidden = True
Range("B12:V12").Select
Selection.Locked = False
Selection.FormulaHidden = True
ActiveWindow.SmallScroll Down:=-210
'Sheets("Adresse").EnableOutlining = True Für Gliederung
ActiveSheet.EnableAutoFilter = True ' Für AutoFilter
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, _
UserInterfaceOnly:=True, Password:="Passwort"
Range("M14").Select
End With
End Sub
Lieber Reinhard, ich hoffe, Du blickst durch. Wenn nicht, bin ich Dir auch nicht böse.
Viele Grüße
Konni