Registriert seit: 27.04.2014
Version(en): Privat: Office Home & Business 2019 / Arbeit: MS365
Hallo Attila,
fast perfekt!! :)
Es funktioniert prima, das einzige was noch nicht ganz so ist wie ich es möchte, wenn ich eine Nummer lösche, dann werden zwar die Daten bis Spalte 15 gelöscht, aber die Formeln ab Spalte 16 nicht, diese sollen auch gelöscht werden!
Wie kann ich das ändern?
Vielen Dank im Voraus
LG
Alexandra
Registriert seit: 14.04.2014
Version(en): 2003, 2007
Hallo Alexandra,
dann teste so:
Code: Private Sub Worksheet_Change(ByVal Target As Range)
Dim varZ As Variant
Dim lngZ As Long, i As Long
If Target.Column = 1 And Target.Row > 2 Then
On Error GoTo errorhandler
Application.EnableEvents = False
lngZ = Selection.Rows.Count + Target.Row - 1
For i = Target.Row To lngZ
If Cells(i, 1) = "" Then
Range(Cells(i, 2), Cells(i, 46)).ClearContents
Else
Select Case Len(Application.Substitute(Cells(i, 1), " ", ""))
Case 6
Cells(i, 1) = Left(Application.Substitute(Cells(i, 1), " ", ""), 2) & _
" " & Mid(Application.Substitute(Cells(i, 1), " ", ""), 3, 2) & _
" " & Right(Application.Substitute(Cells(i, 1), " ", ""), 2)
Case 9
Cells(i, 1) = Left(Application.Substitute(Cells(i, 1), " ", ""), 3) & _
" " & Mid(Application.Substitute(Cells(i, 1), " ", ""), 4, 3) & _
" " & Right(Application.Substitute(Cells(i, 1), " ", ""), 3)
End Select
varZ = Application.Match(Cells(i, 1), Range("A3:A" & Target.Row - 1), 0)
If IsNumeric(varZ) Then
Range(Cells(i, 5), Cells(i, 15)).Value = Range(Cells(varZ + 2, 5), Cells(varZ + 2, 15)).Value
Else
Range(Cells(i, 5), Cells(i, 15)).ClearContents
End If
Range(Cells(i, 16), Cells(i, 46)).Formula = Range(Cells(3, 16), Cells(3, 46)).Formula
End If
Next i
End If
errorhandler:
Application.EnableEvents = True
If Err Then MsgBox "Fehler-Nr.: " & Err.Number & vbLf & vbLf & Err.Description
End Sub
Gruß Atilla
Registriert seit: 27.04.2014
Version(en): Privat: Office Home & Business 2019 / Arbeit: MS365
Hallo Attila,
perfekt!!!! :)
Ich habe ein kleine Änderung vorgenommen, da der die Formeln sonst nicht angepasst werden auf die jeweilige Zeile sondern werden 1 zu 1 kopiert, folgendes habe ich geändert:
Range(Cells(3, 16), Range(Cells(i, 16), Cells(i, 46))).Formula = Range(Cells(3, 16), Cells(3, 46)).Formula
Ich hoffe das passt so? Es scheint jedenfalls zu funktionieren!
Vielen Dank für deine wie immer klasse Hilfe
LG
Alexandra
Registriert seit: 14.04.2014
Version(en): 2003, 2007
Hallo Alexandra,
falls das mit den Formeln nicht passen sollte, dann teste folgenden Code:
Code: Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim varZ As Variant
Dim lngZ As Long, i As Long
If Target.Column = 1 And Target.Row > 2 Then
On Error GoTo errorhandler
Application.EnableEvents = False
lngZ = Selection.Rows.Count + Target.Row - 1
For i = Target.Row To lngZ
If Cells(i, 1) = "" Then
Range(Cells(i, 2), Cells(i, 46)).ClearContents
Else
Select Case Len(Application.Substitute(Cells(i, 1), " ", ""))
Case 6
Cells(i, 1) = Left(Application.Substitute(Cells(i, 1), " ", ""), 2) & _
" " & Mid(Application.Substitute(Cells(i, 1), " ", ""), 3, 2) & _
" " & Right(Application.Substitute(Cells(i, 1), " ", ""), 2)
Case 9
Cells(i, 1) = Left(Application.Substitute(Cells(i, 1), " ", ""), 3) & _
" " & Mid(Application.Substitute(Cells(i, 1), " ", ""), 4, 3) & _
" " & Right(Application.Substitute(Cells(i, 1), " ", ""), 3)
End Select
varZ = Application.Match(Cells(i, 1), Range("A3:A" & Target.Row - 1), 0)
If IsNumeric(varZ) Then
Range(Cells(i, 5), Cells(i, 15)).Value = Range(Cells(varZ + 2, 5), Cells(varZ + 2, 15)).Value
Else
Range(Cells(i, 5), Cells(i, 15)).ClearContents
End If
Range(Cells(3, 16), Cells(3, 46)).Copy
Cells(i, 16).PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End If
Next i
End If
errorhandler:
Application.EnableEvents = True
If Err Then MsgBox "Fehler-Nr.: " & Err.Number & vbLf & vbLf & Err.Description
End Sub
Gruß Atilla
Registriert seit: 14.04.2014
Version(en): 2003, 2007
31.03.2015, 21:11
(Dieser Beitrag wurde zuletzt bearbeitet: 31.03.2015, 21:13 von atilla.)
Hallo Alexandra,
unsere Antworten haben sich gerade überschnitten.
Mit den Formeln hatte ich schon geahnt. Nimm den gerade eingestellten Code.
Kannst aber auch mit Deiner Änderung beibehalten.
Gruß Atilla
Registriert seit: 27.04.2014
Version(en): Privat: Office Home & Business 2019 / Arbeit: MS365
Hallo Attila,
absolut PERFEKT!!!! :)
Vielen lieben Dank nochmals
LG & schönen Abend
Alexandra
Registriert seit: 14.04.2014
Version(en): 2003, 2007
Hallo Alexandra,
nur der Vollständigkeit halber, Deine Änderung :
Range(Cells(3, 16), Range(Cells(i, 16), Cells(i, 46))).Formula = Range(Cells(3, 16), Cells(3, 46)).Formula
sollte richtigerweise so geschrieben werden:
Range(Cells(3, 16), Cells(i, 16)).Formula = Range(Cells(3, 16), Cells(3, 46)).Formula
Das hatte ich eben nicht richtig in Augenschein genommen und übersehen.
Gruß Atilla
Registriert seit: 27.04.2014
Version(en): Privat: Office Home & Business 2019 / Arbeit: MS365
Hi Attila,
so wird aber nur die Zelle in der Spalte 16 befüllt!?
LG
Alexandra
Registriert seit: 14.04.2014
Version(en): 2003, 2007
Hallo Alexandra,
richtig, kleiner Fehler von mir eingearbeitet um Deine Aufmerksamkeit zu testen
Range(Cells(3, 16), Cells(i, 46)).Formula = Range(Cells(3, 16), Cells(3, 46)).Formula
Wenn Du den Code mit Copy nutzen möchtest, dann sollten da noch zwei Dinge ergänzt werden.
Die Bildschirmaktualisierung sollte abgeschaltet werden und die Zwischenablage sollte geleert werden.
Deswegen hier der gesamte Code mit den Ergänzungen:
Code: Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim varZ As Variant
Dim lngZ As Long, i As Long
If Target.Column = 1 And Target.Row > 2 Then
On Error GoTo errorhandler
Application.EnableEvents = False
lngZ = Selection.Rows.Count + Target.Row - 1
For i = Target.Row To lngZ
If Cells(i, 1) = "" Then
Range(Cells(i, 2), Cells(i, 46)).ClearContents
Else
Select Case Len(Application.Substitute(Cells(i, 1), " ", ""))
Case 6
Cells(i, 1) = Left(Application.Substitute(Cells(i, 1), " ", ""), 2) & _
" " & Mid(Application.Substitute(Cells(i, 1), " ", ""), 3, 2) & _
" " & Right(Application.Substitute(Cells(i, 1), " ", ""), 2)
Case 9
Cells(i, 1) = Left(Application.Substitute(Cells(i, 1), " ", ""), 3) & _
" " & Mid(Application.Substitute(Cells(i, 1), " ", ""), 4, 3) & _
" " & Right(Application.Substitute(Cells(i, 1), " ", ""), 3)
End Select
varZ = Application.Match(Cells(i, 1), Range("A3:A" & Target.Row - 1), 0)
If IsNumeric(varZ) Then
Range(Cells(i, 5), Cells(i, 15)).Value = Range(Cells(varZ + 2, 5), Cells(varZ + 2, 15)).Value
Else
Range(Cells(i, 5), Cells(i, 15)).ClearContents
End If
Application.ScreenUpdating = False
Range(Cells(3, 16), Cells(3, 46)).Copy
Cells(i, 16).PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End If
Next i
Cells(i, 1).Select 'Falls nicht nötig dann diese Zeile löschen; ohne wird der Bereich angesprungen in die hineinkopiert wurde
End If
errorhandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
If Err Then MsgBox "Fehler-Nr.: " & Err.Number & vbLf & vbLf & Err.Description
End Sub
Dir auch noch einen schönen Abend oder besser eine gute Nacht
Gruß Atilla
Folgende(r) 1 Nutzer sagt Danke an atilla für diesen Beitrag:1 Nutzer sagt Danke an atilla für diesen Beitrag 28
• cysu11
Registriert seit: 27.04.2014
Version(en): Privat: Office Home & Business 2019 / Arbeit: MS365
Hi Attila,
dann habe ich ja den Test bestanden :)
Funktioniert nun beides!!!
Danke nochmals & guten Nacht
Alexandra
|