an alle VBA Profis

Hallo liebe VBA Profis,
mein Name ist elRamin bin neu hier und bitte um eure Hilfe.
Erklärung:
Aus einer Datenbank wird eine Exceltabelle erstellt mit den Namen EU.xlsx. Dort befinden sich Namen und Vornamen mit einigen Zahlen. Diese Zahlen möchte ich in eine andere Tabelle (Test 2.xlsm) übertragen.
in EU werden nur Mitarbeiter gelistet wo Änderungen vorhanden sind.
In Test 1 werden alle Mitarbeiter gelistet die ich habe und neue Mitarbeiter hinzugefügt.
In Test 2 werden alle Mitarbeiter gelistet aus Test 1 mit der Formel (=MTRANS()) so das ich in Test 2 auch Mitarbeiter habe die es in EU zur Zeit nicht gibt. Neue Mitarbeiter könnten aber in der nächsten erstellten EU vorhanden sein.
Mein Wunsch:
Die Namen und Vornamen aus EU mit Test 2 vergleichen, (Name und Vorname manchmal doppelt vorhanden) wenn Name und Vorname in Test 2 vorhanden ist dann aus EU die Zahlen in die jeweilige Spalte kopieren.
Achtung in EU nebeneinander aber in Test 2 nicht. (Überschriften beachten)
Ich hoffe das mir jemand helfen kann und die Beschreibung einigermaßen verständlich ist.
Lade die drei Tabellen hoch nur ohne echten Namen aus Datenschutz gründen.
Wäre nett wenn man mir ein Makro dazu bastelt und vielleicht mit Erklärungen dazu was jeder einzelne Schritt dort tut.
Ich möchte gerne dazu lernen und verstehen.
Vielen Dank
elRamin
https://www.herber.de/bbs/user/135376.xlsx
https://www.herber.de/bbs/user/135377.xlsm
https://www.herber.de/bbs/user/135378.xlsm

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo elRamin,
schlechter Betreff - dieser soll das Problem kurz Beschreiben
Hier mein Vorschlag für Makros die den Abgleich durchführen.
Die Makros must du in deiner Datei Test2.xlsm in einem allgemeinen Modul einfügen.
Die Datei Test2.xlsm muss die aktive Arbeitsmappe sein, wenn das Makro gestartet wird.
LG
Franz

Sub Aktualisieren_aus_EU()
Dim strPfadEU As String, strDateiEU As String, bolEU_open As Boolean
Dim strNameEU As String
Dim arrNamen As Variant
Dim wkbEU As Workbook, wksEU As Worksheet, zeiEU As Long, spaEU As Long
Dim wkbZiel As Workbook, wksZiel As Worksheet, zeiZiel As Long, spaZiel As Long
Dim StatusCalc As Long
'Ziel-Datei setzen (=momentan in Excel aktive Arbeitsmappe)
Set wkbZiel = ActiveWorkbook
'Ziel-Tabellenblatt setzen (= 1. Tabellenblatt in Zieldatei, ggf anpassen)
Set wksZiel = wkbZiel.Worksheets(1)
'Name der Datei mit den neuen Daten
strDateiEU = "EU.xlsx"
'Verzeichnis von Datei "EU.xlsx"
strPfadEU = wkbZiel.Path    'Verzeichnis ggf. anpassen
'Prüfen ob Datei "EU.xlsx" schon geöffnet ist
If fncCheckWorkbookOpen(strDateiEU) = True Then
Set wkbEU = Application.Workbooks(strDateiEU)
bolEU_open = True
Else
If Dir(strPfadEU & "/" & strDateiEU) = "" Then
MsgBox "Datei """ & strDateiEU & """ nicht gefunden" & vbLf & vbLf & _
"Bitte prüfen, ob Verzeichnis """ & strPfadEU _
& """ korrekt bzw. Datei vorhanden!", _
vbInformation + vbOKOnly, "Offnen der Datei """ & strDateiEU & """"
GoTo Beenden
Else
'Datei EU.xlsx schreibgeschützt öffnen
Set wkbEU = Application.Workbooks.Open(Filename:=strPfadEU & "/" & strDateiEU, _
ReadOnly:=True)
bolEU_open = False
End If
End If
'Blatt mit den neuen Daten setzen
Set wksEU = wkbEU.Worksheets(1)
With wksZiel
'Namen und Vornamen in Zieldatei für schnellere Verarbeitung in Array speichern
arrNamen = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp).Offset(0, 1))
End With
'Makro-Bremsen lösen
With Application
.ScreenUpdating = False
StatusCalc = .Calculation 'Berechnungs-Modus merken
.Calculation = xlCalculationManual
End With
With wksEU
'Zeilen in Datei mit neuen Daten abarbeiten
For zeiEU = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
'Name|Vorname zum Vergleich in Variable speichern
strNameEU = .Cells(zeiEU, 1).Text & "|" & .Cells(zeiEU, 2).Text
For zeiZiel = 2 To UBound(arrNamen, 1)
If strNameEU = arrNamen(zeiZiel, 1) & "|" & arrNamen(zeiZiel, 2) Then
For spaEU = 3 To .Cells(1, .Columns.Count).End(xlToLeft).Column
spaZiel = 0
'Ziel-Spalte setzen für Spalten in EU.xlsx
Select Case spaEU
Case 3 'Rest EU alt
spaZiel = 3 'Rest EU
Case 4 'Rest EU neu
spaZiel = 4 'EU Neu
Case 5 'SZU
spaZiel = 5 'SZU EU
Case 6 'ELZ Rest
spaZiel = 9 'ELZ Rest
End Select
If spaZiel > 0 Then
'Wert aus EU.xlsx in Ziel-Arbeitsmappe eintragen
wksZiel.Cells(zeiZiel, spaZiel).Value = .Cells(zeiEU, spaEU).Value
End If
Next spaEU
End If
Next
Next zeiEU
End With
' Datei "EU.xlsx ggf. wieder schliessen, wenn sie nicht geöffnet war
If bolEU_open = False Then
wkbEU.Close savechanges:=False
End If
'Makro-Bremsen zurücksetzen
With Application
.ScreenUpdating = True
.Calculation = StatusCalc
End With
Beenden:
End Sub
Public Function fncCheckWorkbookOpen(strWorkbookName As String) As Boolean
Dim wkb As Workbook
On Error GoTo Fehler
Set wkb = Application.Workbooks(strWorkbookName)
fncCheckWorkbookOpen = True
Fehler:
End Function

Sub Suchen() Windows("Open-Übertragung.xlsm").Activate Sheets("Tabelle1").Activate Range("A2").Select Range("A2").Select Name$ = ActiveCell Vorname$ = ActiveCell Windows("EU.xlsm").Activate Sheets("Tabelle1").Activate Range("A1").Select Z = 1 Range("A2").Select For Z = 2 To 100 Step 1 c$ = Cells(Z, 1) 'Vergleichswert in C$ If c$ = Name$ Then Go Sub GefundenName ' If C$ = GB$ Then Go Sub GefundenVorname If c$ = "" Then GoTo Ende Next GefundenName: Windows("Open-Übertragung.xlsm").Activate Sheets("Tabelle1").Activate ' ActiveCell.Offset(0, 1).Select c$ = Cells(Z, 1).Select ActiveCell.Offset(0, 1).Select Vorname$ = ActiveCell Windows("EU.xlsm").Activate Sheets("Tabelle1").Activate ' Range("B7").Select Cells.Find Vorname$ Z = 1 For Z = 2 To 100 Step 1 c$ = Cells(Z, 2) 'Vergleichswert in C$ If c$ = Vorname$ Then Go Sub Kopieren Next Return Kopieren: c$ = Cells(Z, 2).Select Windows("EU.xlsm").Activate Sheets("Tabelle1").Activate ' DGS$ = ActiveCell ActiveCell.Offset(0, 1).Select Selection.Range(Cells(1, 1), Cells(1, 1)).Copy 'Kopiert Zahlen Windows("Open-Übertragung.xlsm").Activate Sheets("Tabelle1").Activate ActiveCell.Offset(0, 1).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False Return Ende: Windows("Open-Übertragung.xlsm").Activate Sheets("Tabelle1").Activate Range("A1").Select End Sub das Makro funktionierte nur bis zur 2 ten Marion und kopierte immer wieder Zahlen hinein. Also vielen Dank dafür schönen Abend. LG elRamin

Beliebteste Forumthreads (12 Monate)

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread