Clever-Excel-Forum

Clever-Excel-Forum > Office-Anwendungen > Excel > Alternative zu vlookup!
Normale Version: Alternative zu vlookup!
Du siehst gerade eine vereinfachte Darstellung unserer Inhalte. Normale Ansicht mit richtiger Formatierung.
Seiten: 1 2 3

cysu11

31.03.2015, 20:46
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

31.03.2015, 20:53
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

31.03.2015, 21:07
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

31.03.2015, 21:08
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

31.03.2015, 21:11
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

31.03.2015, 21:14
Hallo Attila,


absolut PERFEKT!!!! :)



Vielen lieben Dank nochmals
LG & schönen Abend
Alexandra

atilla

31.03.2015, 21:23
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

31.03.2015, 21:31
Hi Attila,


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


LG
Alexandra

atilla

31.03.2015, 21:43
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

cysu11

31.03.2015, 21:57
Hi Attila,


dann habe ich ja den Test bestanden :)


Funktioniert nun beides!!!


Danke nochmals & guten Nacht
Alexandra
Seiten: 1 2 3
Clever-Excel-Forum > Office-Anwendungen > Excel > Alternative zu vlookup!