Daten Übertragung von Tabelle1 in Tabelle2

[Pirat2015]

was ich noch festgestellt habe, das makro sagt immer, "In Materialübersicht nicht gefunden!" aber die pack stücke sind in der Materialübersicht drine.

Kann es sein, das irgendwas falsch gemacht habe beim anpassen?

[schauan]

Hallöchen,

Kann es sein, das irgendwas falsch gemacht habe beim anpassen?

kann ich nicht ausschließen. In dem Beispiel wird ja was gefunden und auch übertragen …

Weiterhin würde es sehr gut sein wenn das Marko die Tabelle selber öffnet.

Wenn die Datei dort liegt wo Du den Pfad programmiert hast sollte sie auch aufgehen.

Kann man den Code abändert, das es zuerst die Transportnummer sucht,

… wird schwierig. Du würdest dann Daten aus verschiedenen Spalten von bestimmten Zeilen der einen Datei in bestimmte zusammenhängende Spalten der gefilterten Zeilen der anderen übertragen müssen … Vom Prinzip her könnte man das mit Arrays lösen - erst die Quellzeile einlesen, dann in ein zweites Array nur die betreffenden Zellen aus dem ersten Array übertragen und dann das zweite Array in den Zielbereich schreiben.

[Pirat2015]

schauan --> OK

aber jetzt zu diesen CODE: Hier gib doch ein Befehl welche besagt die Tabelle zu öffnen wenn die geschlossen ist, es passiert aber nicht. Wie ändere ich das? 

Code:

On Error Resume Next
'Prüfen ob Materialliste offen ist, sonst Öffnen!
Set WbMt = Workbooks(MTL).Worksheets(1)
If Err > 0 Then
   Workbooks.Open Pfad & MTL
   Set WbMt = Workbooks(MTL).Worksheets(1)
End If
On Error GoTo 0

und dann habe ich mit F8 den Code Laufen lassen er hängt in diese Warte Schleife

Code:

If Not rFind Is Nothing Then
           Adr1 = rFind.Address
           Do
              rFind.Offset(0, 42) = AC.Offset(0, 19)  'ETA Port
              rFind.Offset(0, 43) = AC.Offset(0, 9)   'Container Nr.
              rFind.Offset(0, 44) = AC.Offset(0, 12)  'Transpor Nr.
              Set rFind = WbMt.Columns(1).FindNext(rFind)
           Loop Until Adr1 = rFind.Address
        End If
     Next AC

an was kann liegen?

und was muss ich beim MTL angeben? nur die Datei Name oder auch was anderes.
PS: meine Datei liegt auf einen Server : ist die Eingabe der Adresse so richtig

Code:

ption Explicit
Const MTL = "Dateiname.xlsm"
Const Status = "I1"  'Zelle f?r Statusanzeige F1
Const Pfad = "file:///\\opc.test.com/ und so weiter --> ich kopiere den Pfad direkt aus der Excel

Danke

[schauan]

Hallöchen,

Datei öffnen:

Der Code aktiviert die Datei falls sie offen ist. Falls nicht, versucht er, sie mit den programmierten Daten für Pfad und Dateiname zu öffnen. Da die Fehlermeldungen deaktiviert sind, merkst Du an der Stelle nicht, ob da was nicht stimmt.

Du könntest das so abändern:

Code:

On Error Resume Next
'Prüfen ob Materialliste offen ist, sonst Öffnen!
Set WbMt = Workbooks(MTL).Worksheets(1)
If Err > 0 Then
   err.clear
   Workbooks.Open Pfad & MTL
   if err > 0 then Msgbox "Datei nicht vorhanden, ich beende!": Exit sub
   Set WbMt = Workbooks(MTL).Worksheets(1)
End If
On Error GoTo 0

---

"lange Leitung"

Dein Code hält sich vermutlich lange auf, weil Du z.B. eventuell nach einem Leerstring suchst, wenn in AC mal nix steht. Da Du in der Suche die komplette Spalte hast, könnte die Anzahl Leerzellen im 7-stelligen Bereich liegen und das zu durchsuchen dauert schoon etwas ...

---

Server:

wenn ich mal was auf einem Server liegen habe, dann ist das bei mir in der Regel nicht im Internet. Deine Adresse sieht so aus …
Also bei mir steht dann z.B. etwas wie \\server\freigabe\pfad\datei

[Pirat2015]

OK, ich sehe gerade das der pfad falsch ist, excel schreib das er keine Verbindung zu der Datei aufbauen kann.
Die Datei liegt in der Claud und ich verwende den genauen pfad aus der excel selber.

Was kann ich da machen?

zu der Schleife, ich möchte ja daß das Makro nur eine Spalte genau nach den Packstücken durchsucht welche in der Colliliste sind.
Sobald der letze Packstück aus der Colli liste in Materialübersicht liste gefunden ist, soll die Suche unterbrochen werden.

Wie kann man das machen?

[schauan]

Hallöchen,

eventuell musst Du nicht die ganze Spalte durchsuchen. Du könntest den Bereich z.B. so eingrenzen:

...Range("A1:A" & cells(rows.count,1).end(xlup).row))…


dann sucht er nur bis zur letzten gefüllten Zelle in Spalte A

[Pirat2015]

Habe jetzt die Schleife begrenz:

Code:

'Schleife um alle Transportdaten zu ?bertragen
     For Each AC In .Range("D16:D30000" & lz1)
        Set rFind = WbMt.Columns(1).Find(What:=AC.Value, After:=WbMt.Cells(1, 1), LookIn:= _
            xlValues, LookAt:=xlWhole, SearchDirection:=xlNext, MatchCase:=False)
        'Fehlermeldung wenn Packst?ck Nr. nicht gefunden wird!!
        If rFind Is Nothing Then MsgBox AC & "In SSMS nicht gefunden!"
       
        If Not rFind Is Nothing Then
           Adr1 = rFind.Address
           Do
              rFind.Offset(0, 42) = AC.Offset(0, 19)  'ETA Port
              rFind.Offset(0, 43) = AC.Offset(0, 9)   'Container Nr.
              rFind.Offset(0, 44) = AC.Offset(0, 12)  'Transpor Nr.
              Set rFind = WbMt.Columns(1).FindNext(rFind)
           Loop Until Adr1 = rFind.Address
        End If
     Next AC

bekomme folgenden fehler:

Laufzeitfehler 1004 --> Anwendungs- oder objektdefinierter fehler

---

Also ich glaube es häng wirklich was an der Schleife:

Ich kann jetzt die Datei öffnen, danach passiert nichts mehr --> wie gesagt mit der F8 geht er immer die schleife neu durch:

Code:

If ActiveWindow.Caption = MTL Then ThisWorkbook.Activate
Application.ScreenUpdating = True

With ThisWorkbook.Worksheets(1)
     'LastZell in Transportschein Spalte A suchen
     lz1 = .Cells(Rows.Count, 1).End(xlUp).Row
     .Range(Status).Value = Empty  'Status l?schen
     Application.ScreenUpdating = False
     
     'Schleife um alle Transportdaten zu ?bertragen
     For Each AC In .Range("D16:D" & Cells(Rows.Count, 1).End(xlUp).Row)
        Set rFind = WbMt.Columns(1).Find(What:=AC.Value, After:=WbMt.Cells(1, 1), LookIn:= _
            xlValues, LookAt:=xlWhole, SearchDirection:=xlNext, MatchCase:=False)
        'Fehlermeldung wenn Packst?ck Nr. nicht gefunden wird!!
        If rFind Is Nothing Then MsgBox AC & "In SSMS nicht gefunden!"
       
        If Not rFind Is Nothing Then
           Adr1 = rFind.Address
           Do
              rFind.Offset(0, 42) = AC.Offset(0, 19)  'ETA Port
              rFind.Offset(0, 43) = AC.Offset(0, 9)   'Container Nr.
              rFind.Offset(0, 44) = AC.Offset(0, 12)  'Transpor Nr.
              Set rFind = WbMt.Columns(1).FindNext(rFind)
           Loop Until Adr1 = rFind.Address
        End If
     Next AC

was kann ich machen?

---

Wenn ich das jetzt so abändere

Code:

With ThisWorkbook.Worksheets(1)
     'LastZell in Transportschein Spalte A suchen
     lz1 = .Cells(Rows.Count, 1).End(xlUp).Row
     .Range(Status).Value = Empty  'Status l?schen
     Application.ScreenUpdating = False
     
     'Schleife um alle Transportdaten zu ?bertragen
     For Each AC In .Range("A6:A" & Cells(Rows.Count, 1).End(xlUp).Row)
        Set rFind = WbMt.Columns(1).Find(What:=AC.Value, After:=WbMt.Cells(4, 1), LookIn:= _
            xlValues, LookAt:=xlWhole, SearchDirection:=xlNext, MatchCase:=False)
        'Fehlermeldung wenn Packst?ck Nr. nicht gefunden wird!!
        If rFind Is Nothing Then MsgBox AC & "In SSMS nicht gefunden!"
       
        If Not rFind Is Nothing Then
           Adr1 = rFind.Address
           Do
              rFind.Offset(0, 42) = AC.Offset(0, 19)  'ETA Port
              rFind.Offset(0, 43) = AC.Offset(0, 9)   'Container Nr.
              rFind.Offset(0, 44) = AC.Offset(0, 12)  'Transpor Nr.
              Set rFind = WbMt.Columns(1).FindNext(rFind)
           Loop Until Adr1 = rFind.Address
        End If
     Next AC

Dann kommt die Fehlermeldung Packstück in SSMS nicht gefunden, der gesuchte Packstück steht in Zeile D, was muss ich abändern?

[schauan]

Hallöchen,

also, erst mal zur Schleife und dem Find.
Eine Begrenzung hast Du ja schon

lz1 = .Cells(Rows.Count, 1).End(xlUp).Row
'Schleife um alle Transportdaten zu ?bertragen
For Each AC In .Range("D16:D30000" & lz1)

korrekt wäre wohl

lz1 = .Cells(Rows.Count, 1).End(xlUp).Row
'Schleife um alle Transportdaten zu uebertragen
For Each AC In .Range("D16:D" & lz1)

Spalte D ist doch nicht länger als Spalte A, wo Du lz1 ermittelst?


Hier suchst Du den Wert aus Spalte D in Spalte A

Set rFind = WbMt.Columns(1).Find(What:=AC.Value …

Hier kannst Du auch wieder mit lz1 arbeiten, damit, wie gesagt, bei leerem Eintrag nicht jede Zelle genommen wird, entweder auch mit lz1 arbeiten
Set rFind = WbMt.Range("A16:A" & lz1).Find(What:=AC.Value …

oder vielleicht noch besser, Du suchst nur, wenn was in den Zellen steht:

Statt
Set rFind = WbMt.Range("A16:A" & lz1).Find(What:=AC.Value …

dann
If Ac.Value <> "" Then
Set rFind = WbMt.Range("A16:A" & lz1).Find(What:=AC.Value …

und vor Next AC noch einmal eine Zeile mit End If

[Pirat2015]

Vielen Dank, das Thema hab ich jetzt gelöst.
Ich habe eine andere frage: Die Datei welche mein Code aufmacht liegt auf einen Server, die Excel wird in schreibgeschützten Modus geöffnet und der Code bleib stecken solange man das nicht Manuel bestätigt, das man die Dateil bearbeiten möchte.

weiß du zufällig wie ich es lösen kann --> also Datei soll in Hintergrund aufgemacht werden, daten werden übertragen, Datei wird gespeichert und geschlossen.
Hier nochmal mein neuer kompletter code:

Code:

Option Explicit
Const MTL = "Datei Name"
Const Status = "I1"  'Zelle für Statusanzeige F1
Const Pfad = "Pfad"
'** bitte Pfad + Ordner deiner Materialübersicht angeben!!


'Makro zum Übertrag in Excel
'42 ETA Port, 43 Container, 44 Transport Nr --> SSMS

Sub Transportdaten_übertragen()
    Dim i As Integer
    Dim s As String
    'Dim AC As Range
    Dim rFind As Range
    Dim rQuelle As Range
    Dim Adr1 As String
    Dim j As Integer
    Dim shZiel As Worksheet
   
    Application.Calculation = xlCalculationManual
   
    Application.ScreenUpdating = False
   
    Dim shQuelle As Worksheet
    Set shQuelle = ActiveSheet
   
    On Error Resume Next
    'Prüfen ob Materialliste offen ist, sonst Öffnen!
    Set shZiel = Workbooks(MTL).Worksheets(1)
    If Err > 0 Then
       Err.Clear
       Workbooks.Open Pfad & MTL, Editable:=True
       If Err > 0 Then MsgBox "Datei nicht vorhanden, ich beende!": Exit Sub
       Set shZiel = Workbooks(MTL).Worksheets(1)
    End If
    On Error GoTo 0
   
    If ActiveWindow.Caption = MTL Then ThisWorkbook.Activate
   
       
        Set rQuelle = shQuelle.UsedRange '.Columns("A")
       
        For i = 6 To rQuelle.Rows.Count
       
            s = rQuelle.Cells(i, 1)
           
           
            Set rFind = shZiel.Columns(4).Find(What:=s, LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext, MatchCase:=False)
   
            'Fehlermeldung wenn Packstück Nr. nicht gefunden wird!!
            If rFind Is Nothing Then
                Debug.Print "Packstück " & s & " in Datei nicht gefunden!"
            Else
               
               Adr1 = rFind.Address
               
               Do
                  rFind.Offset(0, -3).Offset(0, 42) = rQuelle.Cells(i, 10) 'Container Nr.
                  rFind.Offset(0, -3).Offset(0, 43) = rQuelle.Cells(i, 20) 'ETA Port
                  rFind.Offset(0, -3).Offset(0, 44) = rQuelle.Cells(i, 13) 'Transpor Nr.
                 
                  Set rFind = shZiel.Columns(4).FindNext(rFind)
               
               Loop While Adr1 <> rFind.Address
           
            End If
         
         Next
   
         'Anzeige der übertragenen Daten in Zelle I1
         shQuelle.Range(Status).Value = "Daten von Packstück  " & shQuelle.Cells(6, 1) & " bis " & shQuelle.Cells(rQuelle.Rows.Count, 1) & " übertragen"


    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
   
End Sub