27.10.2022, 19:29
Hallo liebes Forum
Mein folgendes Problem
Habe nun 2 Arbeitsmappen Quelle und Ziel
Nun möchte ich die Daten der Quelle (DB-Intelligente tabelle beginn D12) in die Ziel (DB-Intelligente tabelle beginn D12) bringen
2 auswahlkriterien stehen zur verfügung Quelle (DB) - Datum und Kunde und für die Ziel (DB) Datum und Kunde
Nun soll wenn ich den Button Import drücke die daten von Quelle (DB) in die Ziel (DB) kopiert werden auf die jeweiligen spalte (jede Spalte vom der Quelle wird nicht benötigt)
Im Vorfeld soll aber überprüft werden ob die Daten schon in der Ziel (DB) vorhanden sind und nur mehr die die neu einträge rüberkopieren
Habe es mal probiert aber dabei ist nicht das gewünschte ergebniss rausgekommen
Danke für eure Hilfe
Mein folgendes Problem
Habe nun 2 Arbeitsmappen Quelle und Ziel
Nun möchte ich die Daten der Quelle (DB-Intelligente tabelle beginn D12) in die Ziel (DB-Intelligente tabelle beginn D12) bringen
2 auswahlkriterien stehen zur verfügung Quelle (DB) - Datum und Kunde und für die Ziel (DB) Datum und Kunde
Nun soll wenn ich den Button Import drücke die daten von Quelle (DB) in die Ziel (DB) kopiert werden auf die jeweiligen spalte (jede Spalte vom der Quelle wird nicht benötigt)
Im Vorfeld soll aber überprüft werden ob die Daten schon in der Ziel (DB) vorhanden sind und nur mehr die die neu einträge rüberkopieren
Habe es mal probiert aber dabei ist nicht das gewünschte ergebniss rausgekommen
Code:
Sub 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