Value = Value mit Bedingung!?

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim rngZelle1 As Range If Not Application.Intersect(Target, Range("O3:O41")) Is Nothing Then Application.EnableEvents = False For Each rngZelle1 In Application.Intersect(Target, Range("O3:O41")) With rngZelle1.Offset(0, 0) If IsEmpty(rngZelle1) Then .ClearContents Else If rngZelle1 "" Or "0" Then .FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-8],Extrahiert!C[-11]:C[-9],3,0),"""")" .Calculate .Value = .Value End If End With Next Application.EnableEvents = True End If Next End Sub

Hallo Thorben,
Sorry, aber ich kann dir beim besten Willen nicht folgen.
Zitat:leider übernimmt er alle Wert als Wert, auch die Null und Leer angezeigten zellen
ist genau das, was ich dir vorausgesagt habe. Also nochmals die Frage (andersherum): Was hat das mit dem Zitat: Die Suchkriterien (G3/D..,J3/D..,M3/D..) sind Vorhanden aber in Spalte "F" in "Extrahiert" werden nach und nach erst die entsprechenden Werte eingetragen.
Dies Werte fangen immer mit "K" an. zu tun?
Warum testest du den Bereich "O3:O41" auf Änderungen? Da stehen doch gem. erster Anfrage Formeln drin! Die Änderung findet doch in Spalte F statt und deren Auswirkung ist unter Umständen, dass die Formeln, dann ein Resultat K... in Spalte O:Q liefern. Was versteh ich da falsch?
Warum schreibst du nun per VBA eine Formel in die Zellen?
Lade eine Beispielmappe hoch, damit man besser versteht, was du überhaupt erreichen willst!
Gruess Hansueli

Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim rC As Range Dim bDoValues As Boolean If Intersect(Target, Range("F:F")) Is Nothing Then Exit Sub For Each rC In Intersect(Target, Range("F:F")) If Not bDoValues And Left(rC.Text, 1) = "K" Then bDoValues = True Next rC If bDoValues Then Application.EnableEvents = False For Each rC In Worksheets("Karte").Range("O3:Q41") If Left(rC.Text, 1) = "K" Then rC.Value = rC.Value Next rC Application.EnableEvents = True End If End Sub

Hab deinen Code ein bischen angepasst.
- "Set wbAct = ActiveWorkbook.Sheets(""Karte"")" wird in jeder Tabelle einfach angepasst.
- wird noch bischen drann gefeilt (Selects etc. fliegen noch raus bzw. werden ersetzt)
Geht so erstmal schnell von der Hand.
Trotzdem Danke

Sub Extrakt()
Dim wbAct As Worksheet
Set wbAct = ActiveSheet
Dim ws As Worksheet
Dim sCode As String
With Application
.DisplayAlerts = False
.EnableEvents = False
.ScreenUpdating = False
End With
For Each ws In ActiveWorkbook.Sheets
If ws.Name = "Extrahiert" Then
ws.Delete
End If
Next ws
'Tabelle Extrahieren Code einfügen
sCode = "Option Explicit" & vbCrLf & _
"Private Sub Worksheet_Change(ByVal Target As Range)" & vbCrLf & _
vbTab & "Dim wbAct As Worksheet" & vbCrLf & _
vbTab & "Set wbAct = ActiveWorkbook.Sheets(""Karte"")" & vbCrLf & _
vbTab & "Dim rC As Range" & vbCrLf & _
vbTab & "Dim bDoValues As Boolean" & vbCrLf & _
vbTab & "If Intersect(Target, Range(""F:F"")) Is Nothing Then Exit Sub" & vbCrLf & _
vbTab & "For Each rC In Intersect(Target, Range(""F:F""))" & vbCrLf & _
vbTab & "If Not bDoValues And Left(rC.Text, 1) = ""K"" Then bDoValues = True" & vbCrLf & _
vbTab & "Next rC" & vbCrLf & _
vbTab & "If bDoValues Then" & vbCrLf & _
vbTab & "Application.EnableEvents = False" & vbCrLf & _
vbTab & "For Each rC In wbAct.Range(""O3:Q41"")" & vbCrLf & _
vbTab & "If Left(rC.Text, 1) = ""K"" Then rC.Value = rC.Value" & vbCrLf & _
vbTab & "Next rC" & vbCrLf & _
vbTab & "Application.EnableEvents = True" & vbCrLf & _
vbTab & "End If" & vbCrLf & _
"End Sub"
Sheets.Add.Name = "Extrahiert"
Sheets("Extrahiert").Move after:=Sheets(Sheets.Count)
ActiveWorkbook.VBProject.VBComponents(ActiveWorkbook.VBProject.VBComponents.Count). _
CodeModule.AddFromString sCode
'Daten in Tabelle Extrahieren einfügen
Dim wbExt As Worksheet
Set wbExt = ActiveWorkbook.Sheets("Extrahiert")
wbExt.Activate
Columns("A:L").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
wbAct.Activate
Range("A2:B41,F2:H41").Select
Selection.Copy
wbExt.Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
wbAct.Activate
Range("A3:B41,I3:K41").Select
Application.CutCopyMode = False
Selection.Copy
wbExt.Activate
Range("A41").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
wbAct.Activate
Range("A3:B41,L3:N41").Select
Application.CutCopyMode = False
Selection.Copy
wbExt.Activate
Range("A80").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("A:E").Select
Application.CutCopyMode = False
Selection.AutoFilter
Range("E1").Select
ActiveSheet.Range("$A$1:$E$118").AutoFilter Field:=5, Criteria1:=""
wbExt.AutoFilter.Sort.SortFields.Clear
wbExt.AutoFilter.Sort.SortFields.Add Key:= _
Range("E1:E118"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortTextAsNumbers
With wbExt.AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Formeln in Karte* eintragen
wbAct.Activate
Range("O3").Select
Range("O3").Value = "=IFERROR(VLOOKUP(RC[-8],Extrahiert!C[-11]:C[-9],3,0),"""")"
Selection.AutoFill Destination:=Range("O3:O41"), Type:=xlFillDefault
Range("O3:O41").Select
Range("O41").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.249946592608417
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.249946592608417
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.249946592608417
.Weight = xlThin
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("P3").Select
Range("P3").Value = "=IFERROR(VLOOKUP(RC[-6],Extrahiert!C[-12]:C[-10],3,0),"""")"
Selection.AutoFill Destination:=Range("P3:P41"), Type:=xlFillDefault
Range("P3:P41").Select
Range("P41").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.249946592608417
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.249946592608417
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.249946592608417
.Weight = xlThin
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("Q3").Select
Range("Q3").Value = "=IFERROR(VLOOKUP(RC[-4],Extrahiert!C[-13]:C[-11],3,0),"""")"
Selection.AutoFill Destination:=Range("Q3:Q41"), Type:=xlFillDefault
Range("Q3:Q41").Select
Range("Q41").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.249946592608417
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.249946592608417
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.249946592608417
.Weight = xlThin
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
wbExt.Activate
With Application
.DisplayAlerts = True
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub

Gruß
Thorben

Beliebteste Forumthreads (12 Monate)

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread