Bei bestimter Bedingung kopieren
04.06.2021 12:36:12
Ilker
ich habe wieder mal ein Problem und hoffe, dass hier weitergeholfen werden kann.
Ich möchte 2 Spalten auf verschiedene Tabellen vergleichen und wenn Werte gleich sind, soll kopiert werden, ansonsten ein Messagebox und kopieren abbrechen.
Vergleich funktioniert und Messagebox kommt aber es kopiert trotztdem. Und die Schleife dauert ewig, wenn es passt und kopiert wird.
Was mache ich denn falsch?
Vielen Dank schon mal.
Sub TransferDetailedEstimate()
Dim clave As String
clave = "test"
If MsgBox("This command will owerwrite everything in this Sheet." & "Do you really want to transfer?", vbYesNo + vbQuestion) = vbYes Then
For i = 4 To 2000
If Sheets("Detailed Estimate").Range("C" & i).Value Sheets("Detailed Forecast").Range("C" & i).Value Then
MsgBox "Number of lines is not the same. Please check and correct the number of lines.", vbCritical
Exit Sub
Else:
Application.ScreenUpdating = False
Sheets("Detailed Forecast").Unprotect clave
Sheets("Detailed Estimate").Range("D4:D2000").Copy
Sheets("Detailed Forecast").Range("D4").PasteSpecial Paste:=xlPasteValues
Sheets("Detailed Estimate").Range("L4:L2000").Copy
Sheets("Detailed Forecast").Range("E4").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
Next
Sheets("Detailed Forecast").Range("D4").Select
Sheets("Detailed Forecast").Protect clave, AllowDeletingRows:=True, AllowFormattingColumns:=True, AllowFormattingCells:=True, AllowFiltering:=True, UserInterfaceOnly:=True
End If
Application.ScreenUpdating = True
End Sub
Anzeige