Identifikationsnummer in Datei 1 auslesen und Daten in Datei 2 einfügen

[Petz1807]

Doch doch die beide Makros sind von dir
Sieh mal hier den verlauf des Beitrages

[Gast 123]

Hallo

ich war bisher nicht im Thread, und habe aus Neugier und Interesse eine höfliche Frage:  ist diese Aufgabe ungelöst??

Ich sehe eine Makro Lösung von Profi snb, mit einem Danke, eine von Fennek.  Aber irgenwie habe ich das Gefühl es klappt immer noch nicht??  
Liege ich da richtig?

mfg  Gast 123

[Fennek]

Hallo Patrick,

stimmt der Code ist von mir und ich habe die Datenquelle gefunden. Diepasst aber nicht mit den Matrikel-Nummern zusammen.

Deshalb hier ungegrüft mit dem Code von snb ergänzt:

Code:

Sub Etudes_hinzufuegen()

Dim WBQ As Workbook
Dim WSZ As Worksheet: Set WSZ = ActiveSheet
Dim WSQ As Worksheet

Pfad = ThisWorkbook.Path & "\"

If Pfad <> "" Then
'automatische Öffnen
sF = Pfad & "AAAA_Matricules_Etudes Avocats.xlsx" 'Filenamen

'Auswahl der Datei
'sF = Application.GetOpenFilename("xlsx-Dateien (*.xlsx),*.xlsx", MultiSelect:=False)
End If

'Set WBQ = Workbooks.Open(sF)
Set WBQ = GetObject(sF)

Set WSQ = WBQ.Sheets(1)

With WSZ
i = 2

Do While .Cells(i, 2) <> ""

'beim 2.Lauf nicht doppelt
If .Cells(i, 3) = "" Then
Set Rng = WSQ.UsedRange.Find(WSZ.Cells(i, 2), , xlValues, xlWhole)
If Not Rng Is Nothing Then
'.Cells(i, 2) = WSQ.Cells(Rng.Row, 2) 'ID aus Spalte B
.Cells(i, 3) = WSQ.Cells(Rng.Row, 6) 'Vorname: F
.Cells(i, 4) = WSQ.Cells(Rng.Row, 5) 'Nachname: E
'Firma, falls kein Name
If IsEmpty(.Cells(i, 3)) And IsEmpty(.Cells(i, 4)) Then .Cells(i, 3) = WSQ.Cells(Rng.Row, 1)
.Cells(i, 6) = WSQ.Cells(Rng.Row, 10) 'Straße: J
.Cells(i, 7) = WSQ.Cells(Rng.Row, 9) 'Hausnummer: I
.Cells(i, 8) = WSQ.Cells(Rng.Row, 11) 'Boîte Postale: K
.Cells(i, 10) = WSQ.Cells(Rng.Row, 12) 'Postleitzahl: L
.Cells(i, 9) = WSQ.Cells(Rng.Row, 15) ' Land: O
.Cells(i, 11) = WSQ.Cells(Rng.Row, 13) 'Ortschaft: M
.Cells(i, 12) = WSQ.Cells(Rng.Row, 14) 'Kanton: N
Else
.Cells(i, 3) = "Pas de données" 'falls ID in der Datenbank nicht vorhanden
End If
End If
'wie Makro 1 <<<<<<<<<<<<<<<<<<<<< ungeprüft >>>>>>>>>>>>>>>>>>>>>>
If InStr(.cells(i, 17), "-") Then .Cells(i, 17) = Split(.cells(i, 17), "-")(2)

i = i + 1
Loop
End With

WBQ.Close 0

End Sub

mfg

(Der Ansatz mit "Selected Cell" war damals gedacht, um einzelne Zeilen nachträglich zu bearbeiten)

[Petz1807]

Vielen dank werde mal ausprobieren

[Petz1807]

Code:

Sub Etudes_hinzufuegen()
Dim WBQ As Workbook
Dim WSZ As Worksheet: Set WSZ = ActiveSheet
Dim WSQ As Worksheet
Pfad = ThisWorkbook.Path & "C:\Users\kargp\Desktop\"
If Pfad <> "" Then
'automatische Öffnen
sF = Pfad & "Tabelle1.xlsx" 'Filenamen
'Auswahl der Datei
'sF = Application.GetOpenFilename("xlsx-Dateien (*.xlsx),*.xlsx", MultiSelect:=False)
End If
'Set WBQ = Workbooks.Open(sF)
Set WBQ = GetObject(sF)
Set WSQ = WBQ.Sheets(1)
With WSZ
i = 2
Do While .Cells(i, 2) <> ""
'beim 2.Lauf nicht doppelt
If .Cells(i, 3) = "" Then
Set Rng = WSQ.UsedRange.Find(WSZ.Cells(i, 2), , xlValues, xlWhole)
If Not Rng Is Nothing Then
'.Cells(i, 2) = WSQ.Cells(Rng.Row, 2) 'ID aus Spalte B
.Cells(i, 3) = WSQ.Cells(Rng.Row, 6) 'Vorname: F
.Cells(i, 4) = WSQ.Cells(Rng.Row, 5) 'Nachname: E
'Firma, falls kein Name
If IsEmpty(.Cells(i, 3)) And IsEmpty(.Cells(i, 4)) Then .Cells(i, 3) = WSQ.Cells(Rng.Row, 1)
.Cells(i, 6) = WSQ.Cells(Rng.Row, 10) 'Straße: J
.Cells(i, 7) = WSQ.Cells(Rng.Row, 9) 'Hausnummer: I
.Cells(i, 8) = WSQ.Cells(Rng.Row, 11) 'Boîte Postale: K
.Cells(i, 10) = WSQ.Cells(Rng.Row, 12) 'Postleitzahl: L
.Cells(i, 9) = WSQ.Cells(Rng.Row, 15) ' Land: O
.Cells(i, 11) = WSQ.Cells(Rng.Row, 13) 'Ortschaft: M
.Cells(i, 12) = WSQ.Cells(Rng.Row, 14) 'Kanton: N
Else
.Cells(i, 3) = "Pas de données" 'falls ID in der Datenbank nicht vorhanden
End If
End If
'wie Makro 1 <<<<<<<<<<<<<<<<<<<<< ungeprüft >>>>>>>>>>>>>>>>>>>>>>
If InStr(.Cells(i, 17), "-") Then .Cells(i, 17) = Split(.Cells(i, 17), "-")(2)
i = i + 1
Loop
End With
WBQ.Close 0
End Sub

Jetzt sagt er mir "Datei- oder Klassenname während Automatisierungsoperation nicht gefunden" doch der Pfad zur Datei stimmt

[Fennek]

Hallo,

es geht nur eins von beiden:

Code:

Pfad = ThisWorkbook.Path & "C:\Users\kargp\Desktop\"

mfg

[Petz1807]

Hallo Fennek,

Könntest du mir hier in diesem VBA noch hinzufügen dass wenn die Daten nicht gefunden werden also "pas de données" dass er die Zeilen zusätzlich noch einfärbt so dass man es besser sieht.

Resp. auch dass sich ein Fenster öffnet mit der Anzahl nicht gefundenen Daten. Aber so dass ich im VBA diese Option ein und ausschalten kann.

Vielen lieben dank

[Petz1807]

Oder kann mir hier vielleicht ein anderer auf die schnelle weiter helfen um die Zeilen im Vba anzupassen

[schauan]

Hallöchen,

ich kann mir nicht vorstellen, dass so was passt:

Pfad = ThisWorkbook.Path & "C:\Users\kargp\Desktop\"

Pfad könnte dann z.B. so aussehen:

C:\TestC:\Users\kargp\Desktop\

Könntest du mir hier in diesem VBA noch hinzufügen dass wenn die Daten nicht gefunden werden also "pas de données" dass er die Zeilen zusätzlich noch einfärbt so dass man es besser sieht.

Da könntest Du mal das EInfärben einer Zelle aufzeichnen und den Code entsprechend erweitern.
Du bekommst dann in etwa so etwas:

Code:

Sub Makro1()
'
' Makro1 Makro
'

'
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
End Sub

Du schaust im aufgezeichneten Code, wo die Farbe geändert wird. Das ist die Stelle mit .Color Allerdings ist hier noch etwas mehr relevant. In der Zeile mit With steht noch Selection.Interior. Selection wäre dein cells(i, 3). Interior wäre die Beschreibung, was gefärbt wird. Könnte ja auch die Schrift oder ein Rahmen sein.

Füge also in Deinem Code eine Zeile ein, beginnend mit

.Cells(i, 3).Interior.Color = …

und statt der Punkte Deine Farbe.

[Petz1807]

Hallo,

Vielen lieben dank für deine Hilfe das klappt auch doch leider beim zweiten durchlauf des VBA Scripts werden die Felder jetzt nicht mehr weiss fals die ID vorhanden ist?

Mfg