hab jetzt erstmal eine Lösung ohne Like o. WSColl
04.03.2014 13:19:45
Thorben
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