Code funktioniert nicht
13.08.2014 09:57:26
Pascal
Ich habe eine bitte an euch.
Mein Problem:
Ich möchte Zahlen auslesen und den Auftrag in ein anderen Register auf die entsprechende Zeile einfügen. Dieser Code ist gegangen, obwohl ich nichts verändert habe geht dieser Code nicht mehr. Ich weiss nicht wieso.
Habt ihr vielleicht eine Ahnung?
Was ich bis jetzt ausprobiert habe ohne Erfolg:
- Kompatibilität xls xlsm usw.
- Leerschläge in den Zellen
Details:
Auslesen - AuftrSNrEingelesenMatrix Auftrag zum einfügen = "F2"
Abgleichen mit AuftrSNrEingelesenMatrix - FlasherDaten Spalte C
Einfügen - FlasherDaten Spalte O Doppeltvergabe Spalte P
Wenn ihr noch mehr Infos braucht, bitte unsigniert melden.
Vielen Dank
Liebe Grüsse
Pascal
Code:
Sub Kopieren()
If Range("AuftrSNrEingelesenMatrix!F2") "" Then
'Ist bereits ein Wert vorhanden?
If .Range("O" & lSpalte_AA).Value "" And _
iÜberschreiben = False And _
.Range("O" & lSpalte_AA).Value .Range("AA" & lSpalte_AA).Value Then
iVerhalten = MsgBox(.Range("O" & lSpalte_AA).Value & " durch " & .Range("AA" _
_
& lSpalte_AA).Value & " ersetzen?", vbYesNoCancel, "Daten Überschreiben?")
'Überschreiben
If iVerhalten = vbYes Then
iÜberschreiben = True
.Range("O" & lSpalte_AA).Value = .Range("AA" & lSpalte_AA).Value
'Zur betroffenen Zeile gehen
ElseIf iVerhalten = vbNo Then
Dim a5 As String
a5 = MsgBox("In Spalte Doppelvergabe einfügen?.", vbYesNo, "Doppelvergabe?") _
_
If a5 = vbYes Then
Call Kopieren2
GoTo Beenden
ElseIf a5 = vbNo Then
.Range("O" & lSpalte_AA).Select
GoTo Beenden
End If
End If
Else
.Range("O" & lSpalte_AA).Value = .Range("AA" & lSpalte_AA).Value
End If
End If
Next lSpalte_AA
End With
Beenden:
'Blind aus
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End If
End Sub
Sub Kopieren2()
'Blind an
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
'Variablendeklaration
Dim lSpalte_AA As Long, iÜberschreiben As Boolean, iVerhalten As Long
'Withblock öffnen
With ThisWorkbook.Worksheets("FlasherDaten")
'Schleife starten
For lSpalte_AA = 1 To .UsedRange.SpecialCells(xlCellTypeLastCell).Row
'Git es einen Ausgangswert?
If .Range("AA" & lSpalte_AA).Value "" Then
'Ist bereits ein Wert vorhanden?
If .Range("P" & lSpalte_AA).Value "" And _
iÜberschreiben = False And _
.Range("P" & lSpalte_AA).Value .Range("AA" & lSpalte_AA).Value Then
iVerhalten = MsgBox("Doppelvergabe: " & .Range("P" & lSpalte_AA).Value & " _
_
durch " & .Range("AA" & lSpalte_AA).Value & " ersetzen?", vbYesNoCancel, "Daten Überschreiben?") _
'Überschreiben
If iVerhalten = vbYes Then
iÜberschreiben = True
.Range("P" & lSpalte_AA).Value = .Range("AA" & lSpalte_AA).Value
'Zur betroffenen Zeile gehen
ElseIf iVerhalten = vbNo Then
.Range("P" & lSpalte_AA).Select
GoTo Beenden2
End If
Else
.Range("P" & lSpalte_AA).Value = .Range("AA" & lSpalte_AA).Value
End If
End If
Next lSpalte_AA
End With
Beenden2:
'Blind aus
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub