Excel VBA Suchen und Hinzufügen

[Sonorc2]

Hallo,

ich möchte in excel weitere Informationen zu einer bestehenden Tabelle hinzufügen.

Sheet A ist die Main Tabelle wo alle Informationen zusammen kommen

Hier habe ich eigentlich als eindeutige ID die Entladl.Nr. aber in Sheet ZusatzInfoTu ist die leider nicht hinterlegt

Hier habe ich mir nun gedacht, dass ich einfach nach der Depot Nummer gehe und dazu den TU vergleiche (beim TU die ersten 3 Buchstaben). Leider finde ich keine Lösung



Hier mein Code: (Also das Kopieren in Sheed A bekomme ich hin aber die Abfrage um die MW und AH zu zu ordnen nicht)

Sub ImportZusatzInfoTu()

    With Sheets("ZusatzInfoTu")
  
        Dim Var2 As Variant
      
        sheetName = ActiveSheet.Name
  
        letztezeile = .Cells(.Rows.Count, 6).End(xlUp).Row
        letztezeileTest = Sheets(sheetName).Cells(.Rows.Count, 2).End(xlUp).Row

        For i = 4 To letztezeile
      
        Var1 = Application.Match(.Cells(i, 6), Sheets(sheetName).Cells(.Rows.Count, 2), 0)
        Var2 = Application.Match(.Cells(i, 6), Sheets(sheetName).Columns(2), 0)

        If IsError(Var2) Then
          
        Else
              
            If CStr(UCase(Left(Range(Sheets(sheetName).Cells(Sheets(sheetName).Cells(Var2, 1).Row, 7).Address(False, False)).Value, 3))) = CStr(.Cells(i, 7)) Then
                Debug.Print Var2, Range(Sheets(sheetName).Cells(Sheets(sheetName).Cells(Var2, 1).Row, 3).Address(False, False)), CStr(.Cells(i, 7)), .Rows(i).Range("J1"), .Rows(i).Range("K1")

            Else
                'Debug.Print Var2, Range(Sheets(sheetName).Cells(Sheets(sheetName).Cells(Var2, 1).Row, 3).Address(False, False)), CStr(.Cells(i, 7)), .Rows(i).Range("J1"), .Rows(i).Range("K1")
            End If
          
        End If
          
        Next
      
    End With

End Sub

 

[Yaslaw]

Irgendwie scheint mir das ein wenig umständlich.
Also, du willst aus ZusatzInfoTu die SPalten J & K nach Sheet A kopieren.
So aus dem Kopf kann ich gerade nicht helfen, müsste ein wenig pröbeln. Kannst du eine Datei mit Testdaten zur Verfügung stellen?

Aja, noch ein Tipp. Verwende nie in einem Makro ActiveSheet. Das ist zu unsicher, dass das richitge verwendet wird. Wenn du aus versehen ein anderes Sheet offen hast, dann gehts nicht.

 

[Sonorc2]

Ja klar, hier ist eine testdatei.

Ich möchte die gelbmarkierten Felder befüllen aus dem Sheet ZusatzInfoTu (da kommen die brücken oder sattel nummer rein)



Sattel oder brücken nummer grün. Die Datei bekomme ich so exportiert leider ohne feste Entladenummer. Hier kann man nur nach den Namen und Partner Relation gehen. Z.b. G6 UND G7 ist das gleiche haus aber zwei verschiedene LKWs kommen an mit den daten von J6 und J7+K7.

Wenn z.b. Haus 11 von 10 Lkws angeliefert wird sind in Sheed A auch Automatisch10 Einträge von dem Haus aber ohne die zusatzinfo.

Update: ZusatzInfoTu
Hier bei G4 habe ich die Unternehmer schon automatisch auf 3 stellen gekürtzt, die wollte ich dann bei A in G6 vergleichen dann mit:

UCase(Left(Range(Sheets(sheetName).Cells(Sheets(sheetName).Cells(Var2, 1).Row, 7).Address(False, False)).Value, 3))) = CStr(.Cells(i, 7)

Gruß

 

[Zvoni]

Wieso per VBA?
Excel-eigene Funktionen gehen auch.
Siehe Anhang - Tabelle "A" - Spalten I und J

 

[Yaslaw]

Entweder wi Zvoni schreibt.
Wenn Extern, dann ginge es eleganter üper Power Query oder wenn man über ADODB ein SQL-Zugriff macht. Aber das ist komplizierter und braucht Einarbeitung.

Über klassisches Excel-VBA könnte man das zum Beispiel so lösen

Option Explicit

'Spaltennummern der Quelle (src)
Const C_SRC_DEPOT_COLNR% = 6
Const C_SRC_TU_COLNR% = 7
Const C_SRC_MW_COLNR% = 10
Const C_SRC_AH_COLNR% = 11
'Erste Datenzeile der Quelle
Const C_SRC_FIRST_DATA_ROWNR% = 4

'Spaltennummer des Ziels (trg)
Const C_TRG_DEPOT_COLNR% = 2
Const C_TRG_TU_COLNR% = 7
Const C_TRG_MW_COLNR% = 9
Const C_TRG_AH_COLNR% = 10
'Erste Datenzeile des Ziels
Const C_TRG_FIRST_DATA_ROWNR% = 6

Public Sub importZusatzInfoTu1()
    'Worksheets auslesen
    Dim wsSrc As Worksheet:     Set wsSrc = ThisWorkbook.Sheets("ZusatzInfoTu")
    Dim wsTrg As Worksheet:     Set wsTrg = ThisWorkbook.Sheets("A")
    
    'Datenranges auslesen
    Dim rngSrc As Range:        Set rngSrc = wsSrc.Range("A" & C_SRC_FIRST_DATA_ROWNR, wsSrc.Cells(wsSrc.Cells(wsTrg.rows.Count, 3).End(xlUp).row, 16))
    Dim rngTrg As Range:        Set rngTrg = wsTrg.Range("A" & C_TRG_FIRST_DATA_ROWNR, wsTrg.Cells(wsTrg.Cells(wsTrg.rows.Count, 1).End(xlUp).row, 10))
    
    'Iterator über alle Datenzeilen des Ziels
    Dim rowTrg As Range:        For Each rowTrg In rngTrg.rows
        'Depot und TU auslesen
        Dim depot$:                 depot = rowTrg.Cells(1, C_TRG_DEPOT_COLNR).Value
        Dim tu$:                    tu = Left(rowTrg.Cells(1, C_TRG_TU_COLNR).Value, 3)
            
        'Iterator über alle Datenzeilen der Quelle
        Dim rowSrc As Range:        For Each rowSrc In rngSrc.rows
            'Depot und TU vergleichen
            If rowSrc.Cells(1, C_SRC_DEPOT_COLNR%).Value = depot And rowSrc.Cells(1, C_SRC_TU_COLNR).Value = tu Then
                'MW und MV übernehmen
                rowTrg.Cells(1, C_TRG_MW_COLNR).Value = rowSrc.Cells(1, C_SRC_MW_COLNR).Value
                rowTrg.Cells(1, C_TRG_AH_COLNR).Value = rowSrc.Cells(1, C_SRC_AH_COLNR).Value
                'Suche in Quelle abbrechen (Iterator rowSrc)
                Exit For
            End If
        Next rowSrc
    Next rowTrg
   
End Sub

 

[Zvoni]

Unabhängig ob jetzt mit meiner oder Yaslaw's Variante:
Funktioniert natürlich nur dann eindeutig, wenn sicher ist, dass die Kombination aus erste drei Zeichen von TU und der Depot-Nummer auch tatsächlich eineindeutig ist (in Datenbank-Sprache: Ein kombinierter Primär-Schlüssel).
Sobald da eine "mögliche" zweite Kombination ins Spiel kommt, knallts.
Beispiel: Du bekommst hinzu: Depot 32 - SVERIGE Transport
Und schon schepperts bei beiden Varianten

 

[Yaslaw]

Bei meiner Version knallt es nicht, er nimmt einfach nur den ersten Treffer

 

[Zvoni]

Das meinte ich mit "knallt": Er erwartet Äpfel, bekommt aber Birnen angezeigt.
In meiner Version wird auch der erste Treffer zurückgegeben

 

[Sonorc2]

Ich danke euch beiden

Ihr habt mir sehr geholfen. Beide sachen gehen sehr gut!!!