Alternative zu vlookup!

[cysu11]

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

[atilla]

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

[cysu11]

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

[atilla]

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

[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.

[cysu11]

Hallo Attila,


absolut PERFEKT!!!! :)



Vielen lieben Dank nochmals
LG & schönen Abend
Alexandra

[atilla]

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.

[cysu11]

Hi Attila,


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


LG
Alexandra

[atilla]

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

[cysu11]

Hi Attila,


dann habe ich ja den Test bestanden :)


Funktioniert nun beides!!!


Danke nochmals & guten Nacht
Alexandra