Dieses Forum nutzt Cookies
Dieses Forum verwendet Cookies, um deine Login-Informationen zu speichern, wenn du registriert bist, und deinen letzten Besuch, wenn du es nicht bist. Cookies sind kleine Textdokumente, die auf deinem Computer gespeichert werden. Die von diesem Forum gesetzten Cookies werden nur auf dieser Website verwendet und stellen kein Sicherheitsrisiko dar. Cookies aus diesem Forum speichern auch die spezifischen Themen, die du gelesen hast und wann du zum letzten Mal gelesen hast. Bitte bestätige, ob du diese Cookies akzeptierst oder ablehnst.

Ein Cookie wird in deinem Browser unabhängig von der Wahl gespeichert, um zu verhindern, dass dir diese Frage erneut gestellt wird. Du kannst deine Cookie-Einstellungen jederzeit über den Link in der Fußzeile ändern.

Alternative zu vlookup!
#11
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
Antworten Top
#12
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
Antworten Top
#13
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
Antworten Top
#14
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
Antworten Top
#15
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
Antworten Top
#16
Hallo Attila,


absolut PERFEKT!!!! :)



Vielen lieben Dank nochmals
LG & schönen Abend
Alexandra
Antworten Top
#17
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
Antworten Top
#18
Hi Attila,


so wird aber nur die Zelle in der Spalte 16 befüllt!?


LG
Alexandra
Antworten Top
#19
Hallo Alexandra,

richtig, kleiner Fehler von mir eingearbeitet um Deine Aufmerksamkeit zu testen  Wink

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:
  • cysu11
Antworten Top
#20
Hi Attila,


dann habe ich ja den Test bestanden :)


Funktioniert nun beides!!!


Danke nochmals & guten Nacht
Alexandra
Antworten Top


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 2 Gast/Gäste