AW: Daten von extern Importieren
26.10.2022 19:23:20
extern
Habe mal etwas probiert funkt aber nicht
Bräuchte wirklich Hilfe da ich an meine Grenzen stoße
Danke
Sub Geschlossene_Arbeitsmappe()
Dim lngZMax As Long
Dim rngBereichId As Range
Dim sPfad As String
Dim Zeile As Long
Dim wbQuelle As Workbook
Dim s As Long
Dim x As Long
Dim y As Long
Dim z As Long
x = 2
s = 0
Application.ScreenUpdating = False
Application.DisplayAlerts = False
sPfad = "C:\Users\Press\OneDrive\Desktop\Pivotberechnung.xlsm"
If Dir(sPfad) "" Then
Set wbQuelle = Workbooks.Open(sPfad)
With wbQuelle
.Range("D12:Y").Copy ThisWorkbook.Worksheets(1).Range("D12")
lngZMax = .Cells(.Rows.Count, 2).End(xlUp).Row
Set rngBereichId = ThisWorkbook.Worksheets(1).Range("D12:Y" & ThisWorkbook.Worksheets(1).Cells(.Rows.Count, 1).End(xlUp).Row)
ThisWorkbook.Worksheets(1).Range("D12:Y" & .Cells(.Rows.Count, 2).End(xlUp).Row).ClearContents
For w = 2 To lngZMax
If Application.WorksheetFunction.CountIf(rngBereichId, wbQuelle.Cells(w, 1)) = 0 Then
ThisWorkbook.Worksheets(1).Cells(w, 1).EntireRow.Insert
.Cells(w, 2).EntireRow.Copy ThisWorkbook.Worksheets(1).Cells(x, 1)
x = x + 1
ElseIf ThisWorkbook.Worksheets(1).Cells(w, 2).Value .Cells(w, 2).Value Then
.Cells(w, 2).EntireRow.Copy ThisWorkbook.Worksheets(1).Cells(x, 1)
x = x + 1
ElseIf ThisWorkbook.Worksheets(1).Cells(w, 2).Value = .Cells(w, 2).Value And ThisWorkbook.Worksheets(1).Cells(w, 5).Value .Cells(w, 5).Value Then
For i = 1 To Len(.Cells(w, 5))
If Mid(ThisWorkbook.Worksheets(1).Cells(w, 5), i, 1) Mid(.Cells(w, 5), i, 1) Then
.Cells(w, 5).Characters(Start:=i, Length:=i).Font.Color = RGB(255, 0, 0)
End If
Next i
For z = Len(.Cells(w, 5)) To 1 Step -1
If Mid(.Cells(w, 5), z, 1) = Mid(ThisWorkbook.Worksheets(1).Cells(w, 5), Len(ThisWorkbook.Worksheets(1).Cells(w, 5)) - s, 1) Then
.Cells(w, 5).Characters(Start:=z, Length:=z).Font.Color = RGB(10, 0, 0)
Else
GoTo sprung
End If
s = s + 1
Next z
sprung:
.Cells(w, 5).EntireRow.Copy ThisWorkbook.Worksheets(1).Range("D" & x)
x = x + 1
End If
s = 0
Next w
End With
With ThisWorkbook.Worksheets(1)
For y = .Cells(.Rows.Count, 2).End(xlUp).Row To 1 Step -1
If IsEmpty(.Cells(y, 1).Value) Then
.Cells(y, 1).EntireRow.Delete
End If
Next y
End With
wbQuelle.Close SaveChanges:=False
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Call Nav_DB
End Sub