Übertragung multipler Daten aus einer Datei in andere Dateien

[Dschissl]

Hallo

vielleicht ist das Makro von Schauen inzwischen schon erfogreich am laufen? Trotzdem hier meine Lösung.

Ich habe mir auch Gedanken gemacht den Code zu optimieren.  Mal schauen wie gut er geworden ist? 
In der Woche 1 findest du im Bereich W2 - Y4 eine  Liste wieviele Daten kopiert wurden. Inclusive Überlauf!
Mir fiel auf, das bei Alex und Richard die 32 Zeilen zum auflisten nicht ausreichen!  Die brauchen mehr Zeilen.

-->Dein Code ist super Gast123! Genau so habe ich mir das vorgestellt. Erstklassige Arbeit 

Das Makro beendet das auflisten ab Zeile 32 und zählt die überlaufenden Daten als fehlende Zeilen.
Werden ins Sheet weitere Zeilen eingefügt listet das Makro alle Daten bis zur Zelle mit der Summenformel auf.

-->Das mit dem Überlauf ist eine super Idee von dir. Ich habe unbewusst mehrere Doppelbelegungen eingebaut, welche natürlich so in der Einsatzplanung nicht auftreten, weshalb die 32 Zeilen in den Abrechnungen ausreichen sollten, denn ein Arbeitsmonat hat im späteren Anwendungsfall allerhöchstens 23 Arbeitstage (Sa + So entfallen). Dennoch eine klasse Idee für den Fall der Fälle.
-->Es wäre höchstens interessant zu wissen, ob es Doppelbelegungen für einen Wochentag gibt, falls der- oder diejenige, welche(r) die Planung schreibt aus Versehen zwei Personen am selben Tag zu demselben Klienten schickt. Muss aber nicht sein, hat keine Priorität 

Das Makro listet alle 5 Wochen auf.  Man braucht also nicht mehr für jede Woche einen Button.
Aufgelistet werden die Daten im markierten Bereich, unabhängig davon wer in der oberen Zeile steht. s. A2

Frage:  bei der Beispielmappe war ich mir nicht sicher ob beide Werte aufgelistet werden müssen??
Der Name und die Zeiten in der oberen Zeile wo der Patientenname steht. UND die 5. markierte Zeile?
Oder NUR die 5. markierte Zeile, ohne die obere wo in A2 "Maik" steht?  Das müssten wir noch klären.

-->Nein, nur die 6., 7. und 8. Zeile eines jeden Mitarbeiters. Jeder Mitarbeiter (Maik, Jason, Siegfried usw.) hat 8 Zeilen für sich. Die ersten 5 sind gesperrt und zeigen den Mitarbeitern nur wo sie geplant sind. Die anderen 3, farblich grün markierten Zeilen, sind die relevanten Zeilen, welche ausgewertet sollen. Ich habe etwas mit den Daten gespielt und es wird wirklich nur die 6. Zeile eines jeden Mitarbeiters ausgewertet, nicht die 1. Zeile, wo er geplant ist. So soll es sein. 
-->Nun kann es aber sein, dass ein Mitarbeiter an einem Tag bei mehreren Klienten gewesen ist. Kannst du die Auswertung noch auf die 7. und 8. Zeile eines jeden Mitarbeiters erweitern, sodass quasi alle drei farblich grün markierten Zeilen ausgewertet werden? Aktuell wird nur die erste der drei farblich grün markierten Zeilen ausgewertet.

Ich bitte mal zum Testen die Daten in der markierten Zeile gegenüber der oberen Zeile zu ändern.  -->erledigt, klappt genau so wie es soll 
Letzte Frage, soll das Stundenabrechnungs Sheet nach dem Speichern geschlossen werden?  --> Ja, ich denke das wäre sinnvoll, sonst wird es ab einer bestimmten Anzahl an Klienten unübersichtlich, wenn am Ende dutzende Abrechnungen geöffnet sind 
Geändert habe ich das mein Makro bei einer bereits geöffneten Datei keine Fehlermeldung ausgibt. 

mfg Gast 123

Ich experimentiere noch ein wenig mit den Daten, um zu sehen, ob noch weitere Anpassungen nötig sind, aber du bist der Lösung meines Anliegens schon sehr nah gekommen 

VG Dschissl

[Gast 123]

Hallo

es freut mich das mein Code auf Anhieb so gut geklappt hat. Der Gedanke mit Zeile 6,7 kam mir, hatte ich aber verworfen.
Macht nix, es war nicht viel Arbeit das zu ändern. Ich hoffe es klappt fehlerfrei.  Dateien OHNE Überlauf werden geschlossen.
Ich prüfe aber nicht ob sich Arbeitszeiten überschneiden, oder von zwei Mitarbeiter doppelt belegt sind. Zuviel Aufwand.
Bitte prüfe auch ob der Code korrekt läuft, wenn in Zeile 5-7 zwei oder drei - verschiedene Mitarbeiter - stehen.

mfg Gast 123

Code:

Option Explicit
Dim AC As Range, lz1 As Long, lz2 As Long
Const MyPfad = "H:\Forum Clever Jan 2024\Stundenabrechnung 2\"
Const MyPfad2 = "C:\xxx"
Const MyPfad3 = "C:\xxx"
Const MyPfad4 = "C:\xxx"
Const Alex = "Stundennachweis - Alex.xlsx"
Const Rich = "Stundennachweis - Richard.xlsx"
Const Mirko = "Stundennachweis - Mirko.xlsx"
Const Manu = "Stundennachweis - Manu.xlsx"


'Stundenabrechnung neu  12.5.2024

Sub Stundenabrechnung_übertragen()
Dim WbEx As Workbook, Klient As String
Dim ShtX As Worksheet, lsp, k, j, s, z, ü
Application.ScreenUpdating = False
ThisWorkbook.Sheets("Woche 1").Range("X2:Y5") = Empty

On Error Resume Next
Set WbEx = Workbooks(Alex)
If Err > 0 Then Workbooks.Open Filename:=MyPfad & Alex
Set WbEx = Workbooks(Alex)
Klient = "Alex":  GoSub Liste

On Error Resume Next
Set WbEx = Workbooks(Rich)
If Err > 0 Then Workbooks.Open Filename:=MyPfad & Rich
Set WbEx = Workbooks(Rich)
Klient = "Richard":  GoSub Liste

On Error Resume Next
Set WbEx = Workbooks(Mirko)
If Err > 0 Then Workbooks.Open Filename:=MyPfad & Mirko
Set WbEx = Workbooks(Mirko)
Klient = "Mirko":  GoSub Liste

On Error Resume Next
Set WbEx = Workbooks(Manu)
If Err > 0 Then Workbooks.Open Filename:=MyPfad & Manu
Set WbEx = Workbooks(Manu)
Klient = "Manu":  GoSub Liste

MsgBox "Stundennachweise kopiert", vbInformation
Exit Sub

Liste:  ThisWorkbook.Activate
Set WbEx = Workbooks(Klient)
Set ShtX = WbEx.Sheets(1)
lz1 = ShtX.Cells(Rows.Count, 1).End(xlUp).Row
lz2 = ShtX.Cells(Rows.Count, 4).End(xlUp).Row
'Stundenabrechnung alte Daten löschen
ShtX.Range("A6:C" & lz1).ClearContents
ShtX.Range("E6:H" & lz1).ClearContents

z = 6 '** 1.Zeile in Stundenabrechnung
ü = 0 'Zeilen Überlauf in Stundenabrechnung

On Error GoTo Fehler
For k = 1 To 5   'Woche 1 bis 5 auswerten
With ThisWorkbook.Worksheets("Woche " & k)
     lz1 = .Cells(Rows.Count, 1).End(xlUp).Row
     lsp = .Cells(1, Columns.Count).End(xlToLeft).Column

     'Alle Namen (Fett) in Testmappe auswerten
     For Each AC In .Range("A2:A" & lz1)
         If AC.Font.Bold = True And AC.Value <> "" Then
            'Alle Spalten mit Klientnamen übertragen
            For s = 2 To lsp Step 4
              For j = 5 To 7   'Zeile 5 bis 7 auswerten
                If .Cells(AC.Row + j, s) = Klient And _
                   .Cells(AC.Row + j, s + 1) <> Empty Then
                   If z < lz2 Then
                      ShtX.Cells(z, 8) = AC.Value
                      ShtX.Cells(z, 1) = .Cells(1, s)
                      ShtX.Cells(z, 2) = .Cells(AC.Row + j, s + 1)
                      ShtX.Cells(z, 3) = .Cells(AC.Row + j, s + 2)
                      z = z + 1
                   Else
                      ü = ü + 1   'Überlauf Zähler
                   End If
                End If
              Next j
            Next s
         End If
     Next AC
End With
Next k: z = z - 1

     '** Verbundene Zellen können NICHT sortiert werden!
     '** 6 Verbundene Zellen zum sortieren aufheben
     ShtX.Range("E6:G" & z).MergeCells = False
     
     '** 6 Nach Datum und Uhrzeit sortieren
     ShtX.Range("A6:I" & z).Sort Key1:=ShtX.Range("A6"), Order1:=xlAscending, _
        Key2:=ShtX.Range("B6"), Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, _
        MatchCase:=False, Orientation:=xlTopToBottom
     
     '** 6 Verbundene Zellen wiederherstellen
     For j = 6 To z
         ShtX.Cells(j, 5).Resize(1, 3).MergeCells = True
     Next j

     With ThisWorkbook.Worksheets("Woche 1")
         .Range(Klient).Offset(0, 1) = z
         If ü > 0 Then .Range(Klient).Offset(0, 2) = ü
     End With

     If ü > 0 Then MsgBox Klient & " Stundenabrechnung" & vbLf _
                   & ü & " Zeilen Überlauf", vbInformation
WbEx.Save 'Stundennachweis Save
'Schliessen wenn KEIN Überlauf!
If ü = 0 Then WbEx.Close False
Return

Fehler:  MsgBox "unerwarteter Fehler im GoSub Code! - Abbruch!" _
  & vbLf & "Woche " & k & "   " & Klient & "   Zeile " & s & "  ü=" & ü, vbInformation
End Sub

[Dschissl]

Hallo

es freut mich das mein Code auf Anhieb so gut geklappt hat. Der Gedanke mit Zeile 6,7 kam mir, hatte ich aber verworfen.
Macht nix, es war nicht viel Arbeit das zu ändern. Ich hoffe es klappt fehlerfrei.  Dateien OHNE Überlauf werden geschlossen.
Ich prüfe aber nicht ob sich Arbeitszeiten überschneiden, oder von zwei Mitarbeiter doppelt belegt sind. Zuviel Aufwand. -->genau, alles gut, war ja so oder so nicht geplant 
Bitte prüfe auch ob der Code korrekt läuft, wenn in Zeile 5-7 zwei oder drei - verschiedene Mitarbeiter - stehen. -->getestet, funktioniert in der Testmappe einwandfrei, genau so wie es soll 

mfg Gast 123

Ich habe weiter herum experimentiert und versucht das Ganze nun auf die Originaldatei anzuwenden. Dabei erscheint allerdings angehangene Fehlermeldung. Ich habe den Namen geschwärzt, weil es sich um echte Klienten handelt. Mit der Fehlermeldung kann ich nicht viel anfangen. Seltsam ist auch, dass ich in der Originaldatei, wie auch schon in der Testmappe, nur 5 Blätter, also 5 Wochen habe. Warum schreibt er aber was von Woche 6?
Ich hänge dir nochmal den adaptierten Code an.

Code:

Option Explicit
Dim AC As Range, lz1 As Long, lz2 As Long
Const MyPfad = "C:\Users\xxx"
Const Zxxx = "xxx_04_2024.xlsx"
Const Jxxx = "xxx_04_2024.xlsx"
Const Exxx = "xxx_04_2024.xlsx"
Const Fxxx = "xxx_04_2024.xlsx"


'Stundenabrechnung neu  12.5.2024

Sub Stundenabrechnung_übertragen()
Dim WbEx As Workbook, Klient As String
Dim ShtX As Worksheet, lsp, k, j, s, z, ü
Application.ScreenUpdating = False
ThisWorkbook.Sheets("Woche 1").Range("X2:Y5") = Empty

On Error Resume Next
Set WbEx = Workbooks(Zxx)
If Err > 0 Then Workbooks.Open Filename:=MyPfad & Zxx
Set WbEx = Workbooks(Zxx)
Klient = "Zxxx":  GoSub Liste

On Error Resume Next
Set WbEx = Workbooks(Jxx)
If Err > 0 Then Workbooks.Open Filename:=MyPfad & Jxx
Set WbEx = Workbooks(Jxx)
Klient = "Jxx":  GoSub Liste

On Error Resume Next
Set WbEx = Workbooks(Exx)
If Err > 0 Then Workbooks.Open Filename:=MyPfad & Exx
Set WbEx = Workbooks(Exx)
Klient = "Exx":  GoSub Liste

On Error Resume Next
Set WbEx = Workbooks(Fxx)
If Err > 0 Then Workbooks.Open Filename:=MyPfad & Fxx
Set WbEx = Workbooks(Fxx)
Klient = "Fxx":  GoSub Liste

MsgBox "Stundennachweise kopiert", vbInformation
Exit Sub

Liste:  ThisWorkbook.Activate
Set WbEx = Workbooks(Klient)
Set ShtX = WbEx.Sheets(1)
lz1 = ShtX.Cells(Rows.Count, 1).End(xlUp).Row
lz2 = ShtX.Cells(Rows.Count, 4).End(xlUp).Row
'Stundenabrechnung alte Daten löschen
ShtX.Range("A18:C" & lz1).ClearContents
ShtX.Range("E18:H" & lz1).ClearContents

z = 18 '** 1.Zeile in Stundenabrechnung
ü = 0 'Zeilen Überlauf in Stundenabrechnung

On Error GoTo Fehler
For k = 1 To 5   'Woche 1 bis 5 auswerten
With ThisWorkbook.Worksheets("Woche " & k)
     lz1 = .Cells(Rows.Count, 1).End(xlUp).Row
     lsp = .Cells(1, Columns.Count).End(xlToLeft).Column

     'Alle Namen (Fett) in Testmappe auswerten
     For Each AC In .Range("A2:A" & lz1)
         If AC.Font.Bold = True And AC.Value <> "" Then
            'Alle Spalten mit Klientnamen übertragen
            For s = 2 To lsp Step 4
              For j = 5 To 7   'Zeile 5 bis 7 auswerten
                If .Cells(AC.Row + j, s) = Klient And _
                   .Cells(AC.Row + j, s + 1) <> Empty Then
                   If z < lz2 Then
                      ShtX.Cells(z, 8) = AC.Value
                      ShtX.Cells(z, 1) = .Cells(1, s)
                      ShtX.Cells(z, 2) = .Cells(AC.Row + j, s + 1)
                      ShtX.Cells(z, 3) = .Cells(AC.Row + j, s + 2)
                      z = z + 1
                   Else
                      ü = ü + 1   'Überlauf Zähler
                   End If
                End If
              Next j
            Next s
         End If
     Next AC
End With
Next k: z = z - 1

     '** Verbundene Zellen können NICHT sortiert werden!
     '** 6 Verbundene Zellen zum sortieren aufheben
     ShtX.Range("E18:G" & z).MergeCells = False
    
     '** 6 Nach Datum und Uhrzeit sortieren
     ShtX.Range("A18:I" & z).Sort Key1:=ShtX.Range("A18"), Order1:=xlAscending, _
        Key2:=ShtX.Range("B18"), Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, _
        MatchCase:=False, Orientation:=xlTopToBottom
    
     '** 6 Verbundene Zellen wiederherstellen
     For j = 18 To z
         ShtX.Cells(j, 5).Resize(1, 3).MergeCells = True
     Next j

     With ThisWorkbook.Worksheets("Woche 1")
         .Range(Klient).Offset(0, 1) = z
         If ü > 0 Then .Range(Klient).Offset(0, 2) = ü
     End With

     If ü > 0 Then MsgBox Klient & " Stundenabrechnung" & vbLf _
                   & ü & " Zeilen Überlauf", vbInformation
WbEx.Save 'Stundennachweis Save
'Schliessen wenn KEIN Überlauf!
If ü = 0 Then WbEx.Close False
Return

Fehler:  MsgBox "unerwarteter Fehler im GoSub Code! - Abbruch!" _
  & vbLf & "Woche " & k & "   " & Klient & "   Zeile " & s & "  ü=" & ü, vbInformation
End Sub

Ich habe im Header nur die Pfade zu den Stundenabrechnungen und die Dateinamen für die Abrechnungen der Klienten geändert. Im ersten "Sub Stundenabrechnung_übertragen()" dann die jeweiligen Namen angepasst und z=18 gesetzt, weil das ja die 1. Zeile in der Stundenabrechnung ist, ab welcher er beginnt die Daten einzutragen. Oder bedeutet die Fehlermeldung, dass es bei diesem Klienten zu wenig Zeilen gibt?

VG Dschissl

Nachtrag: Ich weiß nicht, ob es relevant ist, aber wenn ich die Stundenabrechnung des Klienten geöffnet habe, während ich das Makro ausführe, überträgt er die Daten alle korrekt, bringt jedoch trotzdem die Fehlermeldung und bricht das Makro ab, sodass nur eine der 4 Abrechnungen (eben die des Klienten hier) mit Daten gefüllt ist.

Nachtrag 2: Es erscheint ebenso eine ähnlich Fehlermeldung, obwohl ich aus meiner Sicht keine Veränderungen am Code oder den Dateien vorgenommen habe. Ich bin ratlos.

[Gast 123]

Hallo

amüsanter "kleiner dummer" Fehler, aber Excel ist da sturheil!   Nennt man Flüchtigkeitsfehler!

In der Beispieldatei befinden sich in den Zellen W2 - W5 Workbook Namen, Alex, Richard, Mirko, Manu
Wenn du diese Zellen anklickst siehst du das statt der Zelladresse diese MTA Namen erscheinen!
Ich habe den Code aber jetzt umgestellt auf Namenssuche mit einer For Next Schleife.
Die Namen in diesen Zellen müssen mit dem Klienten Namen im Code übereinstimmen!

Ein zweiter Fehler war, das du bei Const Zxxx mit drei xxx angegeben hast, aber im Code nur mit Zxx usw.
Wenn du diese Fehler berichtigt hast sollte der Code laufen.  Das Testergebnis war bei mir Null, zuerst verblüffend!
Dann fiel mir aber auf das in der Testdatei ja noch die alten MTA Namen Alex, Richard usw. stehen!

Ich bin gespannt ob der Code nach der Fehlerbeseitigung einwandfrei läuft. Würde mich freuen!

mfg Gast 123


Ersetzte bitte diesen Codeteil durch den neuen Code:
    With ThisWorkbook.Worksheets("Woche 1")
        .Range(Klient).Offset(0, 1) = z
        If ü > 0 Then .Range(Klient).Offset(0, 2) = ü
    End With

Code:

     With ThisWorkbook.Worksheets("Woche 1")
          For Each AC In .Range("W2:W10")
            If AC.Value = Klient Then
               If ü > 0 Then AC.Offset(0, 2) = ü
               AC.Offset(0, 1) = z: Exit For
            End If
         Next AC
     End With

[Dschissl]

Hallo

amüsanter "kleiner dummer" Fehler, aber Excel ist da sturheil!   Nennt man Flüchtigkeitsfehler!

In der Beispieldatei befinden sich in den Zellen W2 - W5 Workbook Namen, Alex, Richard, Mirko, Manu
Wenn du diese Zellen anklickst siehst du das statt der Zelladresse diese MTA Namen erscheinen!
Ich habe den Code aber jetzt umgestellt auf Namenssuche mit einer For Next Schleife.
Die Namen in diesen Zellen müssen mit dem Klienten Namen im Code übereinstimmen! -->erledigt 

Ein zweiter Fehler war, das du bei Const Zxxx mit drei xxx angegeben hast, aber im Code nur mit Zxx usw. -->das waren echte Namen, ich habe sie nur fürs Forum hier mit xxx ersetzt, im Code stimmen sie überein 
Wenn du diese Fehler berichtigt hast sollte der Code laufen.  Das Testergebnis war bei mir Null, zuerst verblüffend!
Dann fiel mir aber auf das in der Testdatei ja noch die alten MTA Namen Alex, Richard usw. stehen!

Ich bin gespannt ob der Code nach der Fehlerbeseitigung einwandfrei läuft. Würde mich freuen!

mfg Gast 123

Hallo Gast,

ich habe den Code mit dem von dir geposteten Code ersetzt und es trug sich wie folgt zu, für mich nicht nachvollziehbar aber spannend. Ich beschreibe es mal.
Wenn ich das Makro nun nach Ersetzen des Codeschnippsels ausführe, erscheint erneut die bereits erwähnte Fehlermeldung (siehe Anlage). Alle Abrechnungen sind dabei geschlossen.

Wenn ich das Makro ausführe, während die Abrechnungsdatei des ersten im Code folgenden Klienten Zxxxm geöffnet ist, erscheint zweite Fehlermeldung (siehe Anlage), bezieht sich auf den zweiten im Code folgenden Klienten Jxxxxn.

Wenn ich alle Abrechnungen geöffnet habe, während ich das Makro ausführe, funktioniert es einwandfrei und genauso wie es soll und es erscheint am Ende die Meldung "Stundennachweise kopiert". Alle Daten werden übertragen, die Abrechnungen bleiben jedoch geöffnet und werden nicht geschlossen. 

VG Dschissl

[Gast 123]

Hallo

deine Schilderung lässt darauf schliessen das es ein Datei Öffnen Problem gibt. Ich habe den Code geändert.
Jetzt bekommst du Open Error per MsgBox gemeldet und in Spalte Z zusätzlich als Text angezeigt!
In dieser Beispieldatei habe ich in die Datei von Alex extra zur Demo einen Fehler eingebaut!

Den neuen Code kannst du aus dem Beispiel übernehmen.  Bitte auf die alte Dateiendung .xls achten!
Ich habe leider nur Excel 2003. Du musst natürlich deine Klienten Namen, Dateien und Pfadnamen anpassen!
Open Fehler heisst, dein Pfad oder Dateiname stimmt nicht!  Deshalb klappt das Makro bei geöffneten Dateien!

Ich bin gespannt ob wir deine Datei jetzt ans laufen bekommen.  In meinem Ordner funktionieren alle Dateien.
Eigene Fehler musst du bitte selbst finden.


mfg Gast 123

[Dschissl]

Hallo Gast,
du hattest Recht. Mein Pfad stimmte nicht. Ich Idiot hatte nur den "\" hinter dem letzten Ordner vergessen zu setzen.   
Nach Korrektur dieses Flüchtigkeitsfehlers läuft nun alles einwandfrei und die Daten werden alle genau dorthin übertragen wo sie hin sollen. Ich danke dir wie verrückt 

Ein letztes Anliegen hätte ich tatsächlich noch, weil es mir beim Betrachten der Originaldatei aufgefallen ist. Ist es möglich auch die Daten zu übertragen, welche den Textstring z.B. "Richard" nicht nur exakt beinhalten, sondern bei welchem dieser um weitere Zeichen erweitert wurde. 

Manchmal schreiben Kollegen nämlich Zusätze hin wenn sie z.B. bei einem Gespräch gewesen sind. Dann steht in den 3 farblich markierten Zeilen eben nicht der exakte String "Richard", sondern z.B. "HPG Richard". Wenn sowas drinsteht, würde er diese Daten ja nicht übertragen, richtig? Das wäre aber vorteilhaft, weil diese Zeiten ebenfalls in die Abrechnung müssten. Das wäre allerdings nur ein Bonus. Wenn du sagst, dass es zu viel Aufwand ist, geht das völlig in Ordnung. Du hast mir schließlich schon genug geholfen.

VG Dschissl

[Gast 123]

Hallo

freut mich sehr das mein Code jetzt einwandfrei klappt.  Hast du gut hingekriegt!  Prima.

Diese kleine Sache noch zu korrigieren war nur wenige Sekunden Arbeit.  
Das schaffst du auch.  Ändere bitte die IF Zeile in dieser For Next Schleife.
Damit wird geprüft ob der Klient (ohne Zusatz) in dieser Zelle vorkommt.
Wie die siehst, wenn man VBA verstanden hat ist das eine Kleinigkeit.

Der alte Befehl lautet:  IF .Cells(AC.Row + j, s) = Klient Then   Bitte ändern in:
              For j = 5 To 7  'Zeile 5 bis 7 auswerten
                If InStr(.Cells(AC.Row + j, s), Klient) And _

mfg Gast 123