Daten aus Excel lesen und in neue Excel schreiben

[Gast 123]

Hallo Issi,

als Anlage eine neue Beispieldatei auf der Basis deiner letzten Ausgangsdatei.  Mir ist aufgefallen das die Spalten zum 1. Beispiel verschoben waren.   

Im neuen Beispiel habe ich oben die Zelle B1 mit dem Datei Namen der Ausgangsdatei. Beim ersten mal solltest du diese Datei per Makro Recorder öffen. weil im Makro zum Öffnen noch ganz unten wo "öffnen" steht dein Pfadname angegeben werden muss. Die Ausgangsdatei wird danach automatisch geschlossen. Mir fiel auf das in der neuen Vorlage keine Mitarbeiter Namen angegeben sind, nur die Personal Nummer. Ich habe mir deshalb seitlich Hilfspalten angelegt um die Namen aus der Hilfsspalte laden zu können. Kann in der Ausgangsdatei ein Wert nicht zugeordnet werden mache ich in Spalte H den Vermerk "No Find".  

Mir faellt gerade ein das ich den Fehlerfall beim Schliessen der Datei nicht berücksichtigt habe.  Habs auf die schnelle im neuen Codes unten korrigiert.  
Der meldet jetzt über Msgbox wenn ein fehler vorliegt und laesst die Ausgangsdatei offen!  Bitte diesen neuen Code im Modul1 auswechseln!!

Ich hoffe wir bekommen mit der Lösung die Sache optimal ans laufen.

mfg Gast 123

Code:

Option Explicit      '24.8.2017  Gast 123  Clever Forum

Public WbA As Workbook
Public PG1 As Worksheet
Public PG2 As Worksheet
Public z1 As Long, Zahl As Double
Public lzT1 As Long, lzPg As Long
Public Txt As String, flg As String
Public i, j, k, sp, Datei As String


'Modul zum auflisten von Page 1
'***  ohne Mitarbeiter Namen  ***

Sub Page1_ausflisten()
Dim f As Integer  'Fehler Zehler
With ThisWorkbook.Worksheets("Tabelle1")
  Application.ScreenUpdating = False
 
  On Error GoTo öffnen
  Set WbA = Workbooks(.[b1].Value)
 
  On Error GoTo Fehler
  Set WbA = Workbooks(.[b1].Value)
  Set PG1 = WbA.Worksheets("Page 1")
 
  lzT1 = .Cells(Rows.Count, 1).End(xlUp).Row
  lzPg = PG1.Cells(Rows.Count, 1).End(xlUp).Row
  sp = .Cells(3, 1).End(xlToRight).Column - 4
  If lzT1 < 4 Then lzT1 = 4

  'alte Stundenliste löschen + Spalte G in Page1
   PG1.Range("H1:H" & lzPg).Clear
  .Range("A4:S" & lzT1).ClearContents

  z1 = 4   '4. Zeile in Tabelle1 (+1)

  'Schleife für Page1 auflisten
  For k = 1 To lzPg
     If Left(PG1.Cells(k, 1), 3) = "PNr" Then
        'Peronal Nr ohne Namen auflisten
        .Cells(z1, 1) = PG1.Cells(k + 1, 1)
       
        '***   dieser Teil deaktiviert  ****
'          Txt = PG1.Cells(k + 1, 3).Value
'         'Peronal Nr und Namen, Vorname ausfüllen
'         .Cells(z1, 1) = PG1.Cells(k + 1, 1)
'         .Cells(z1, 2) = Trim(Left(Txt, InStr(Txt, " ")))
'         .Cells(z1, 3) = Trim(Right(Txt, Len(Txt) - InStr(Txt, " ")))
'
         k = k + 1   'k um eine Zeile weitersetzen
        '***   dieser Teil deaktiviert  ****

        'Schleife für alle Zuschlaege einfügen
        For j = 1 To sp
          If PG1.Cells(k + j, 1) = "" Then Exit For
          If Left(PG1.Cells(k + j, 1), 3) = "PNr" Then Exit For
          If PG1.Cells(k + j, "N") = "0" Then GoTo weiter
          flg = "No Find"   'ggf. Fehlermeldung
         
          'Schleife um Art Überchrift zu prüfen + einfügen
          For i = 1 To sp
              If .Cells(2, i + 4) = PG1.Cells(k + j, "F") Or _
                  .Cells(3, i + 4) = PG1.Cells(k + j, "N") Then
                  Zahl = CDbl(.Cells(z1, i + 4)):  flg = Empty
                 .Cells(z1, i + 4) = Zahl + CDbl(PG1.Cells(k + j, "J"))
                  Exit For
              End If
          Next i
           
          'Fehlermeldung bei ungültiger Art-Nr
          If flg <> Empty Then
             f = f + 1  'Fehler addieren
             PG1.Cells(k + j, "H") = "No Find"
             PG1.Cells(k + j, "H").Font.ColorIndex = 3
          End If
        Next j

weiter:  z1 = .Cells(Rows.Count, 1).End(xlUp).Row + 1
     End If
  Next k

  'neu eingefügt:
  'Mitarbeiter Namen aus Hilsspalte auflisten
   lzT1 = .Cells(Rows.Count, 1).End(xlUp).Row

   For j = 1 To lzT1
   For i = 1 To lzT1
      If Cells(j, 1) = .Cells(i, "V") Then
         Cells(j, 2) = .Cells(i, "W")   'Nachname
         Cells(j, 3) = .Cells(i, "X")   'Vorname
         Exit For
      End If
   Next i
   Next j

  If f > 0 Then MsgBox f & "  Fehler in Ausgangsdatei bitte prüfen !!": Exit Sub

  'Ausgangsdatei schliessen
   Workbooks(Datei).Close savechanges:=False
End With
Exit Sub

öffnen: On Error GoTo 0
  On Error GoTo Fehler
  '** Hier den eigenen Pfad zum Datei Öffnen angeben
  Datei = ThisWorkbook.Worksheets("Tabelle1").Range("B1").Value
  Workbooks.Open Filename:="E:\Excel Forum\Anfrage Offen\" & Datei
  ThisWorkbook.Activate: Resume Next

Fehler:  MsgBox "unerwarteter Fehler:" & vbLf & Error()
End Sub

[Issi]

Hallo, 

entschuldigung, dass ich mich erst jetzt melde, aber war beruflich unterwegs, funktioniert alles super jetzt. Habe es noch mit meinem Code erweitert umd direkt aus PDF Spalten und Zeilen anzupassen und direkt in die Zielexcel zu werfen. Tausenddank!!!!!