[VBA] vorhandenes Makro muss angepasst werden

[DeLaGhetto]

Hallo zusammen,

ich hoffe ihr könnt mir helfen.
Ich habe aktuell folgendes Makro (was auch super seinen Zweck erfüllt):

Code:

Sub RevisionAktualiseren()
'     Alle Dateieinträge in der Revisionsdatei werden
'     mit den Neueinträgen in diesem Blatt aktualisiert.
'     Revisionsdatei wird mit Dialogfenster aufgerufen
  
   Dim Dateiname  As String
   Dim RevDatei   As Workbook
   Dim Zeile      As Long        'Zeile im Blatt
   Dim Rev        As Worksheet   'Revisionsblatt
   Dim Zelle      As Range       'Unterste Zelle im Revisionsblatt
   Dim DateiZelle As Range       'Zelle mit Dateinamen im Revisionsblatt
  
   Application.ScreenUpdating = False
  
   'Revisionsdatei und Blatt wird geöffnet
   With ActiveSheet
      ChDir ThisWorkbook.Path                               'Pfad einstellen
      Dateiname = Application.GetOpenFilename               'Dialog für Dateiauswahl
      If Dateiname = "Falsch" Then Exit Sub                 'Abbruch, wenn keine Datei ausgewählt
      Set RevDatei = Workbooks.Open(Dateiname)              'Revisionsdatei öffnen
      Set Rev = RevDatei.Worksheets("Tabelle1")             'Richtiges Blatt bestimmen
     
      'Alle Zeilen werden durchlaufen
      For Zeile = 2 To .Range("A" & .Rows.Count).End(xlUp).Row
        
         'Einzelne Zeile im Blatt "Ausgangsdatei"
         'Im Blatt "Revisionshistorie" Zeile 2 wird Zelle A und B (Dateiname) von "Ausgangsdatei" gesucht
         Set DateiZelle = Rev.Rows("1:3").Find(.Range("A" & Zeile) & " " & .Range("B" & Zeile), LookIn:=xlValues, lookat:=xlWhole)
        
         If DateiZelle Is Nothing Then
                       
            'Dateiname existiert nicht: Abbruch
            .Activate
            .Cells(Zeile, 1).Resize(1, 8).Select                        'Betreffende Zeile wird markiert
            MsgBox .Range("A" & Zeile) & " " & .Range("B" & Zeile) _
                     & vbCr & "wurde nicht gefunden. " _
                     & vbCr & "Abbruch"                                 'Fehlermeldung
            Exit Sub                                                    'Abbruch
         Else
           
            'Dateiname wurde gefunden
            Set Zelle = Rev.Cells(Rev.Rows.Count, DateiZelle.Column).End(xlUp)   'Letzte beschriebene Zelle
           
            'Einträge werden von "Ausgangsdatei" zu "Revisionshistorie" kopiert
            If .Cells(Zeile, "E") <> "" Then
           
               'Bearbeitername ist eingetragen
               If .Cells(Zeile, "E") = Zelle.Offset(-1) And .Cells(Zeile, "G") = Zelle Then
                 
                  'Bearbeiter und Anfangsdatum sind gleich
                  If .Cells(Zeile, "H") <> Zelle.Offset(, 1) Then
                 
                     'Enddatum nicht gleich: Vervollständigen des letzten Eintrages
                     .Cells(Zeile, "H").Copy Zelle.Offset(, 1)    'Enddatum wird einigetragen
                  End If
               Else
                  
                   'Bearbeiter oder Anfangsdatum sind verschieden: Neueintrag darunter
'                  If Zelle.Row = 2 Then Set Zelle = Zelle.Offset(1)     'Wenn Ersteintrag, muss Zelle um 1 hinunterverschobe werden.
                  If Zelle.Row = 2 Then Set Zelle = Cells(Zelle.Row + 1, Zelle.Column)      'Wenn Ersteintrag, muss Zelle um 1 hinunterverschobe werden.
'                  'Zellen kopieren (Inhalt und Formatierung) von Ausgangsdatei in Rev.datei
'                  .Cells(Zeile, "E").Copy Zelle.Offset(1).Resize(, 2)            'Name wird einigetragen
'                  .Cells(Zeile, "G").Copy Zelle.Offset(2)                        'Anfangsdatum wird eingetragen
'                  .Cells(Zeile, "H").Copy Cells(Zelle.Row + 2, Zelle.Column + 1) 'Enddatum wird einigetragen
                  'Zellen zuweisen (Nur Inhalt) von Ausgangsdatei zur Rev.datei
                  Zelle.Offset(1).Resize(, 2) = .Cells(Zeile, "E")            'Name wird einigetragen
                  Zelle.Offset(2) = .Cells(Zeile, "G")                        'Anfangsdatum wird eingetragen
                  Cells(Zelle.Row + 2, Zelle.Column + 1) = .Cells(Zeile, "H") 'Enddatum wird einigetragen
               End If
            End If
         End If
      Next Zeile
   End With
   RevDatei.Close Savechanges:=True
   Application.ScreenUpdating = True
End Sub

Das Makro macht folgendes:
In der Ausgangsdatei erstellt es aus der Spalte A und Spalte B einen eindeutigen Dateinamen. Anschließend wird in der Revisionsdatei nach diesem eindeutigen Namen gesucht und Name, Zugeteilt Datum und Zurückgegeben Datum eingetragen. Das ganze hat noch ein paar "Sonderregeln", die aber im Makro zu sehen sind.
Bedeutet kurz gesagt, dass mit diesen Tabellen die Revisionshistorie von eindeutigen Dateienamen protokolliert wird.

Jetzt hat sich aber die Revisionstabelle geändert. Die Dateinamen stehen nicht mehr Horizontal (und die Historie dementsprechend darunter), sondern die Dateinamen stehen jetzt vertikal (und die Historie dementsprechend rechts daneben).
Kann mir einer von euch das Makro so anpassen, dass ich jetzt die neue Revisionsdatei benutzen kann? Alle anderen "Sonderregeln" sollen gleich bleiben, außer halt in der "Richtung" gewechselt.

Zur Verdeutlichung habe ich im Anhang alle relevanten Dateien hochgeladen.
Für Gute Arbeit lasse ich auch gerne einen 15€ Amazon Gutschein zukommen. Dann einfach privat an mich schreiben

Danke im Voraus.


  Ausgangsdatei.xlsm (Größe: 48,92 KB / Downloads: 7)

  Revisionsdatei_alt.xlsx (Größe: 815,6 KB / Downloads: 6)

  Revisionsdatei_neu.xlsx (Größe: 101,01 KB / Downloads: 8)

[Ralf A]

Hi,

also, ich würde nicht einmal für 15,99 € das Makro umschreiben... 

Ich sage Dir auch warum.
Man muss nicht alles unterstützen, was wenig sinnvoll ist, nur weil es 15 € dafür gibt...  

Weshalb ist es wenig sinnvoll (aus Datenverarbeitungssicht)
1.: Die Datenstruktur ist total vorm A.... .
2.: Wofür braucht es 2 Dateien?

Meine Empfehlung:
- Eine Datei
- Für jedes Attribut eine eigene Spalte:
      Dateiname | Dateinummer | Name | Letzte Bearbeitung | Zugeteilt | Zurückgegeben

- Darin werden alle Einträge untereinander erfasst (statt nebeneinander für jede Datei).
- Formatiere die Tabelle auch als Tabelle (Strg + t)

Also, im Grunde genau so, wie Du es in der Ausgangsdatei schon hast... Da kannst Du wunderbar nach allen möglichen Attributen filtern oder Dir auch 'ne Pivottabelle draus erstellen lassen.... aber nicht einen solchen Unsinn verzapfen müssen...

[26865]

Lobend muss ich erwähnen: Dir ist klar, dass Hilfe nicht nichts kosten muss, Kompliment. 

Nicht so schön: Das, was du an Zeit und Sorgfalt bei der Beschreibung gespart hast, musste ich an Zeit und Sorgfalt oben drauflegen. 

Folgende Punkte waren Zeitfresser:
- Verbundene Zellen, neben zeitlichem Mehraufwand eine seelische Grausamkeit. + 100%
- Du hast verschwiegen und auch nicht im Code berücksichtigt, dass sich der Aufbau der "Ausgangsdatei" geändert hat. Das, verbunden mit den spärlichen Erläuterungen, macht das Nachvollziehen zu einer Tortur. 
Dein Verweis auf "siehe Code" wäre hilfreich gewesen, würde der Code tatsächlich richtig arbeiten. + 50%
- geringfügiger Umbau des Codes, damit dieser besser lesbar und für zukünftige Wünsche leichter anpassbar ist. + 50 %

nicht berücksichtigt, daher kostenneutral:
- Nicht alle Bedingungen wurden im Ursprungscode bedacht, bleiben ebenfalls unberücksichtigt.
- Kommentare nicht überarbeitet

Die ausgelobten 15 Euro +200% werden dann zu 45 Euro - absolut unangemessen in Anbetracht der Zeit, die ich aufwenden musste, um zum Kern der Aufgabe vorzudringen. In der gleichen Zeit hätte ich mehr erwirtschaften und folglich spenden können, eine Verhandlung darüber wäre also mehr als schwofelig. Klar dürfte auch sein, dass ein derart hilfsbereiter, selbstloser Engel wie ich, Gutmensch erster Güte, NICHT bei Amazon bestellt. Den Betrag überweist du daher bitte zugunsten einer in meiner Signatur aufgeführten Organisation. 

Code:

Option Explicit

Sub RevisionAktualiseren()
'     Alle Dateieinträge in der Revisionsdatei werden
'     mit den Neueinträgen in diesem Blatt aktualisiert.
'     Revisionsdatei wird mit Dialogfenster aufgerufen
 
   Dim RevDatei   As Workbook
   Dim Zeile      As Long        'Zeile im Blatt
   Dim Rev        As Worksheet   'Revisionsblatt
   Dim DateiZelle As Range       'Zelle mit Dateinamen im Revisionsblatt
   
   Dim Dateiname  As String
   Dim Bearbeiter As String
   Dim datZugeteilt As Date
   Dim datZurückgegeben As Date
   
   Dim revZelle      As Range       'Unterste Zelle im Revisionsblatt
   Dim revBearbeiter As String
   Dim revrngZugeteilt As Range
   Dim revrngZurückgegeben As Range
   
   
   Application.ScreenUpdating = False
   
   'Revisionsdatei und Blatt wird geöffnet
   With ThisWorkbook.Worksheets("Zuteilungen")
      ChDir ThisWorkbook.Path                               'Pfad einstellen
      Dateiname = Application.GetOpenFilename               'Dialog für Dateiauswahl
      If Dateiname = "Falsch" Then Exit Sub                 'Abbruch, wenn keine Datei ausgewählt
      Set RevDatei = Workbooks.Open(Dateiname)              'Revisionsdatei öffnen
      Set Rev = RevDatei.Worksheets("Tabelle1")             'Richtiges Blatt bestimmen
     
      'Alle Zeilen werden durchlaufen
      For Zeile = 2 To .Range("A" & .Rows.Count).End(xlUp).Row
         Bearbeiter = .Cells(Zeile, "C").Value
         datZugeteilt = .Cells(Zeile, "D").Value
         If .Cells(Zeile, "E").Value = "" Then datZurückgegeben = 0 Else datZurückgegeben = .Cells(Zeile, "E").Value
         
         'Einzelne Zeile im Blatt "Ausgangsdatei"
         'Im Blatt "Revisionshistorie" Zeile 2 wird Zelle A und B (Dateiname) von "Ausgangsdatei" gesucht
         Dateiname = .Range("A" & Zeile) & " " & .Range("B" & Zeile)
         Set DateiZelle = Rev.Columns(1).Find(Dateiname, LookIn:=xlValues, lookat:=xlWhole)
       
         If DateiZelle Is Nothing Then
                       
            'Dateiname existiert nicht: Abbruch
            Call Application.Goto(Reference:=.Cells(Zeile, 1).Resize(1, 8), scroll:=True)
            MsgBox Dateiname _
                     & vbCr & "wurde nicht gefunden. " _
                     & vbCr & "Abbruch"                                 'Fehlermeldung
            Exit Sub                                                    'Abbruch
         Else
           
            'Dateiname wurde gefunden
            Set revZelle = Rev.Cells(DateiZelle.Row, DateiZelle.Columns.Count).End(xlToLeft)  'Letzte beschriebene Zelle
            If revZelle.Column < 3 Then Set revZelle = Rev.Cells(revZelle.Row, 3)
            revBearbeiter = revZelle.Value
            Set revrngZugeteilt = revZelle.Offset(1, 0)
            Set revrngZurückgegeben = revZelle.Offset(1).Offset(, 1)
           
            'Einträge werden von "Ausgangsdatei" zu "Revisionshistorie" kopiert
            If Bearbeiter <> "" Then
           
               'Bearbeitername ist eingetragen
               If Bearbeiter = revBearbeiter And datZugeteilt = revrngZugeteilt.Value Then
                 
                  'Bearbeiter und Anfangsdatum sind gleich
                  If datZurückgegeben > 0 And datZurückgegeben <> revrngZurückgegeben.Value Then
                     'Enddatum nicht gleich: Vervollständigen des letzten Eintrages
                      revrngZurückgegeben.Value = datZurückgegeben
                  End If
               Else
                  If revBearbeiter <> "" Then
                   'Bearbeiter oder Anfangsdatum sind verschieden: Neueintrag darunter
                     Set revZelle = revZelle.Offset(, 1)
                     Set revrngZugeteilt = revrngZugeteilt.Offset(, 2)
                     Set revrngZurückgegeben = revrngZurückgegeben.Offset(, 2)
                  End If
                  revZelle.Value = Bearbeiter
                  revrngZugeteilt.Value = datZugeteilt
                  If datZurückgegeben > 0 Then revrngZurückgegeben.Value = datZurückgegeben                 'Enddatum wird einigetragen
               End If
            End If
         End If
      Next Zeile
   End With
   RevDatei.Close Savechanges:=True
   Application.ScreenUpdating = True
End Sub

[26865]

Für Gute Arbeit lasse ich auch gerne einen 15€ Amazon Gutschein zukommen. Dann einfach privat an mich schreiben

DeLaGhetto - Letzter Besuch: 08.05.2023, 13:42

Lösung abgreifen und sich wortlos verdrücken, selbstredend ohne zu zahlen. So macht man das wohl heute.

[Ralf A]

...mal abgesehen von seinen falschen Versprechungen... nicht mal ein Dankeschön... 

Nicht nur keine Ahnung. Keinen Anstand hat er außerdem...

[Elex]

Nicht nur keine Ahnung. Keinen Anstand hat er außerdem...

Für solche Aussagen sollte man sich schon mal das TE Verhalten etwas in der Historie anschauen. Da stellt man fest, dass die Aussage schon unangebracht ist. Nur weil er gestern da war heist es doch nicht dass er es schon geprüft und umgesetzt hat.

Gruß Elex

[26865]

in der Historie...

Die Lorbeeren von gestern sind der Kompost von morgen.

Informationen über DeLaGhetto
Letzter Besuch: 09.05.2023, 12:10

Fast 3 Tage ohne ein "Danke" oder "danke, schaue ich mir an, komme allerdings weder heute noch morgen dazu..."
Findest du Ralfs Urteil immer noch unangemessen?

[WillWissen]

Hallo an die Kritiker,

bitte lberuhigt euch mal wieder.

DeLaGhetto hat die letzte Antwort am 7.5 um 18:04 von EarlFred erhalten. Unabhängig davon, dass dieser Beitrag grenzwertig war (für mich ein absolut unnötiger verbaler Angriff auf einen fragenden User), sollte berücksichtigt werden, dass der User um 18 Uhr eventuell nicht mehr im Büro war. Somit wäre erst vor zwei Tagen eine Prüfung und ein Ausprobieren des Vorschlags möglich gewesen. Möglicherweise hat er aber noch andere Prioritäten gesetzt bekommen, dass entsprechende Meldungen noch gar nicht erstattet werden können.

Noch eine Bemerkung nebenbei: unser Forum gibt absolut kostenfreie Tipps und Hilfestellungen. Alles andere ist Privatsache und sollte entsprechend privat abgehandelt werden. Irgendwelche Gedanken an Entlohnung gehören nicht in den Beitrag.

Jm2c

[RPP63]

EarlFred wollte ja nicht persönlich entlohnt werden, sondern diesem Forum eine kleine Spende zukommen lassen …

Den Betrag überweist du daher bitte zugunsten einer in meiner Signatur aufgeführten Organisation.

[26865]

bitte lberuhigt euch mal wieder.

Bis eben war ich ruhig, jetzt bin ich es nicht mehr. Wie kannst du ernsthaft von einem „verbalen Angriff“ reden? Weil ich darauf hingewiesen habe, dass die Aufgabe schlecht beschrieben und der Verweis auf den fehlerhaften Code nicht hilfreich sind? Weil verbundenen Zellen schlecht sind?

Irgendjemand in dieser Firma hat den Code geschrieben, aber offenbar war man dort nicht willens, den Code selbst umzubauen. Und weil man selbst anderes zu tun hat, verspricht man eine Entlohnung - es handelt sich also um eine offen angekündigte Auftragsprogrammierung! Selbstredend fordere ich den mir zustehenden Lohn ein, da gibt es überhaupt nichts anderes anzunehmen! Und selbstredend weise ich darauf hin, dass die ursprüngliche Entlohnung nicht ausreicht, da die angekündigten Bedingungen durch den Auftraggeber nicht eingehalten werden und die notwendige Sorgfalt bei der Auftragsbeschreibung fehlte, was zu Mehraufwand führt.

Und um es klar zu machen: Ohne Vergütung hätte ich mir diese Aufgabe nicht auf den Tisch gezogen: Dort ist nichts, was mir nutzt, kein Wissensgewinn oder Freude in Aussicht, sondern reine, langweilige, unspaßige Fleißarbeit. Ich habe die Aufgabe in Aussicht auf die Entlohnung gelöst. Das Vorenthalten der zugesicherten Entlohnung ist Betrug, nicht anderes! 

Es ist mir auch vollkommen egal, welche Probleme der TE mit seinem Zeitmanagement hat. Er war in der Zwischenzeit mindestens 2x nachgewiesen online, eine kurze Reaktion hätte keine 10 Sekunden gebraucht.

Wenn du also der Meinung bist, Betrüger beschützen zu müssen, bin ich hier falsch. Dann mach meinen Account platt.