Ersetz doch einfach Thisworkbook.path damit, ist auch nichts anderes als ein relativer Pfad.
Option Explicit
Sub ausschneiden()
Dim intRow As Integer, intLastRow As Integer
Dim ASH As Worksheet, gesamt As Worksheet, unbetrachtet As Worksheet
Dim x As Long, y As Long, lngZeilen As Long
Dim rngZelle As Range
Dim lngAnz As Long
Dim V1, V2
Dim NWB As Workbook 'neues workbook
'Zuweisung der Tabellen zu den Variablen
With ThisWorkbook
Set ASH = .ActiveSheet
Set gesamt = .Worksheets("Gesamtauszug")
End With
'Formeln werden entfernt
For Each rngZelle In ASH.UsedRange
'prüfen ob Zelle eine Formel enthält
If rngZelle.HasFormula = True Then
rngZelle.Rows.Delete
lngAnz = lngAnz + 1
End If
Next rngZelle
'hier wird die länge der Quelltabelle ermittelt und in die Zieltabelle eingef?gt
lngZeilen = gesamt.Cells(gesamt.Rows.Count, 1).End(xlUp).Row
x = 1
'*********************
'*Workbook hinzufügen*
'*********************
Set NWB = Workbooks.Add
With NWB
Set unbetrachtet = .Sheets(1)
.Sheets(1).Name = "unbetrachtete Datensätze"
Application.DisplayAlerts = False
.Sheets(2).Delete
.Sheets(2).Delete
Application.DisplayAlerts = True
End With
'Schleife die die Quelltabelle durchsucht und bei bestimmter Bedingung wird die Aktion copy-paste gestartet
For y = 2 To lngZeilen
'Bedingungen
With gesamt
V1 = .Cells(y, 10)
V2 = .Cells(y, 3).Value
End With
If Not V1 Like "W*" _
Or V2 Like "ROTES*" _
Or V2 Like "TANKK*" _
Or V2 Like "EZW*" _
Or V2 Like "FREMD*" Then
gesamt.Rows(y).Cut unbetrachtet.Rows(x)
x = x + 1
End If
Next y
'************************************
'*neues Workbook speichern/schließen*
'************************************
With NWB
.SaveAs Environ("UserProfile") & "\Desktop\Unbetrachtet.xls"
'.Close (False)
End With
'hier werden die leeren Zeilen entfernt
With ASH
intLastRow = .Cells.SpecialCells(xlCellTypeLastCell).Row
For intRow = intLastRow To 1 Step -1
If Application.CountA(.Rows(intRow)) = 0 Then
intLastRow = intLastRow - 1
Else
Exit For
End If
Next intRow
For intRow = intLastRow To 1 Step -1
If IsEmpty(.Cells(intRow, 10)) Then
.Rows(intRow).Delete
End If
Next intRow
End With
End Sub
|