Namenslisten-Vergleich unter der Berücksichtigung der Abteilung

Question

Hallo zusammen,

ich brauche Eure Hilfe. 
Irgendwie arbeitet mein Code nicht. 

Das Makro soll im Arbeitsblatt “Stunden“ arbeiten. Es soll die Namen aus der Zieldatei in der Spalte „A7: A“ mit der Quelldatei in der Spalte „C37:C605“ vergleichen. Bei einer Abweichung der Namen soll das Makro die Kostenstelle der Abweichung in der Quelldatei in der Spalte „H37:H605“ mit den folgenden Kostenstellen „4090“,“1090“ vergleichen. Bei einer Übereinstimmung darf der abweichende Name in das Zielarbeitsblatt unter der betreffenden Kostenstelle mit den folgenden Informationen "Name, Vorname, Personalnummer, Kostenstelle" eingefügt werden. Bei der Übertragung der Kostenstelle in das Zielarbeitsblatt soll die Kostenstelle zwei Mal geschrieben werden.  Beispiel, der erste Eintrag ist in „E13“, der zweite Eintrag der Kostenstelle soll darunter eingefügt werden, also in „E14“.

Bedanke mich im Voraus für die Unterstützung. 

Ich habe es mit dem unteren Code versucht:

Sub Namenvergleich()
    Dim wbQuelle As Workbook
    Dim wbZiel As Workbook
    Dim wsQuelle As Worksheet
    Dim wsZiel As Worksheet
    Dim rngQuelle As Range
    Dim rngZiel As Range
    Dim cell As Range
    Dim found As Range
    Dim Kostenstellen As Variant
    Dim msg As String

    ' Quelldatei und -arbeitsblatt öffnen
    Set wbQuelle = Workbooks.Open(*********Pfad***********)
    Set wsQuelle = wbQuelle.Worksheets("Bereich A")

    ' Zieldatei und -arbeitsblatt öffnen
    Set wbZiel = ThisWorkbook
    Set wsZiel = wbZiel.Worksheets("Stunden")

    ' Kostenstellen definieren
    Kostenstellen = Array("4090", "1090")

    ' Durchlaufen Sie jede Zelle in der Zielarbeitsmappe
    For Each cell In wsZiel.Range("A7:A" & wsZiel.Cells(wsZiel.Rows.Count, "A").End(xlUp).Row)
        ' Suchen Sie nach dem Namen in der Quelldatei
        Set found = wsQuelle.Range("C37:C605").Find(cell.Value, LookAt:=xlWhole)

        ' Wenn der Name gefunden wurde und die Kostenstelle übereinstimmt
        If Not found Is Nothing Then
            If IsInArray(wsQuelle.Cells(found.Row, "H").Value, Kostenstellen) Then
                ' Fügen Sie die Details in die Zieldatei ein
                wsZiel.Cells(cell.Row, "B").Value = wsQuelle.Cells(found.Row, "D").Value
                wsZiel.Cells(cell.Row, "C").Value = wsQuelle.Cells(found.Row, "E").Value
                wsZiel.Cells(cell.Row, "E").Value = wsQuelle.Cells(found.Row, "H").Value
                wsZiel.Cells(cell.Row + 1, "E").Value = wsQuelle.Cells(found.Row, "H").Value
            End If
        Else
            ' Wenn der Name nicht gefunden wurde, fügen Sie ihn zur Nachricht hinzu
            msg = msg & "Name: " & cell.Value & ", Vorname: " & wsZiel.Cells(cell.Row, "B").Value & ", Kostenstelle: " & wsZiel.Cells(cell.Row, "E").Value & vbNewLine
        End If
    Next cell

    ' Wenn es Abweichungen gibt, zeigen Sie eine MsgBox an
    If msg <> "" Then
        If MsgBox("Es gibt Abweichungen:" & vbNewLine & msg & vbNewLine & "Möchten Sie diese übernehmen?", vbYesNo) = vbYes Then
            ' Übernehmen Sie die Änderungen
            wbZiel.Save
        End If
    End If

    ' Schließen Sie die Arbeitsmappen
    wbQuelle.Close SaveChanges:=False
End Sub

' Hilfsfunktion zum Überprüfen, ob ein Wert in einem Array vorhanden ist
Function IsInArray(valToBeFound As Variant, arr As Variant) As Boolean
    Dim element As Variant
    On Error GoTo IsInArrayError: ' Wenn ein Fehler auftritt, dann ist der Wert nicht im Array
    For Each element In arr
        If element = valToBeFound Then
            IsInArray = True
            Exit Function
        End If
    Next element
IsInArrayExit:
    Exit Function
IsInArrayError:
    IsInArray = False
    Resume IsInArrayExit
End Function

https://supportnet.de/forum/?qa=blob&qa_blobid=14903520258640646329

https://supportnet.de/forum/?qa=blob&qa_blobid=8092093177127898443

Answer 1

Hallo zagor,

du hast deine Kostenstellen im Array als Text eingegeben. 

Kostenstellen = Array("4090", "1090")

Damit funktioniert der Vergleich mit den Kostenstellen aus deinem Arbeitsblatt nicht mehr. Auch dein Vergleich der Namen funktioniert nicht wirklich.

Auf Basis deines Codes habe ich dir hier mal eine Alternative gebastelt:

Sub vergleich_neu()

Dim arrQuelle As Variant
Dim lngLetzte As Long
Dim n As Long
Dim lngZeile As Long
Dim bGefunden As Boolean
Dim tMsg As String

'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

'Quelldatei öffenen - Pfad anpassen
Workbooks.Open ("C:\Test\Anwesenheit.xlsx")

With ActiveWorkbook
  With .Worksheets("Bereich A")
    'letzte beschriebene Zeile in Spalte C ermitteln
    lngLetzte = .Cells(Rows.Count, 3).End(xlUp).Row
    'alle Daten ab Zeile 38 in Array einlesen
     arrQuelle = .Range("C38:H" & lngLetzte)
   End With
  'Quelldatei wieder schließen; Änderungen nicht speichern
  .Close (False)
End With

With ThisWorkbook.Worksheets("Stunden")
  'letzte beschriebene Zeile in Spalte A ermitteln
    lngLetzte = .Cells(Rows.Count, 1).End(xlUp).Row
   
    'Namen aus arrQuelle mit Namen in Tabelle vergleichen
    For n = LBound(arrQuelle, 1) To UBound(arrQuelle, 1)
       bGefunden = False       'Marker zurücksetzen
       'Namen nur bei Kostenstelle 1090 oder 4090 überprüfen
       If arrQuelle(n, 6) = 1090 Or arrQuelle(n, 6) = 4090 Then
         'aktuelle Tabelle durchlaufen
          For lngZeile = 8 To lngLetzte
           If .Cells(lngZeile, 1).Value = arrQuelle(n, 1) Then
             .Cells(lngZeile, 2) = arrQuelle(n, 2)  'Vorname in Spalte B
             .Cells(lngZeile, 3) = arrQuelle(n, 3)  'Pers. ID in Spalte C
             .Cells(lngZeile, 5) = arrQuelle(n, 6)  'Kostenstelle in Spalte E
             .Cells(lngZeile + 1, 5) = arrQuelle(n, 6) 'Kostenstelle in Spalte E eine Zeile tiefer
             bGefunden = True                   'Marker für gefunden
           End If
          Next lngZeile
          'falls nichts gefunden, dann Nachricht schreiben
          If bGefunden = False Then tMsg = tMsg & "Name: " & arrQuelle(n, 1) & ", Vorname: " & arrQuelle(n, 2) & ", Kostenstelle: " & arrQuelle(n, 6) & vbNewLine
         End If
      Next n
   
End With

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

 ' Wenn es Abweichungen gibt, zeigen Sie eine MsgBox an
    If tMsg <> "" Then
        If MsgBox("Es gibt Abweichungen:" & vbNewLine & tMsg & vbNewLine & "Möchten Sie diese übernehmen?", vbYesNo) = vbYes Then
            ' Übernehmen Sie die Änderungen
            'wbZiel.Save
        End If
    End If
End Sub

Ich hoffe, ich habe das richtig interpretiert. Den Code bei Ausgabe der Messagebox musst du noch auf deine Bedürfnisse anpassen.

Gruß

M.O.

Answer 2

Ohhh, vielen Dank. Ich dachte, dass ich mit der Funktion ausgehebelt hatte.

Wie kann ich nach der Messagebox die gefundenen Abweichungen in die Zieldatei unter der richtigen Kostenstelle einfügen lassen? Danke schön

Answer 3

Hallo,

dein Namensvergleich funktioniert, nur das Schreiben der fehlenden Namen in die Messagebox hat nicht funktioniert (habe mich etwas unklar ausgedrückt).

Schau mal, ob das Makro so funktioniert, wie du willst:

Sub vergleich_neu()

Dim arrQuelle As Variant
Dim arrFehlend() As Variant
Dim lngLetzte As Long
Dim f As Long
Dim n As Long
Dim k As Long
Dim lngZeile As Long
Dim bGefunden As Boolean
Dim tMsg As String
Dim rngZelle As Range
Dim rngErgebnis As Range
Dim arrKostenstellen

' Kostenstellen definieren
 arrKostenstellen = Array(1090, 4090)

'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

'Quelldatei öffenen
Workbooks.Open ("C:\Test\Anwesenheit.xlsx")

With ActiveWorkbook
  With .Worksheets("Bereich A")
    'letzte beschriebene Zeile in Spalte C ermitteln
    lngLetzte = .Cells(Rows.Count, 3).End(xlUp).Row
    'alle Daten ab Zeile 38 in Array einlesen
     arrQuelle = .Range("C38:H" & lngLetzte)
   End With
  'Quelldatei wieder schließen; Änderungen nicht speichern
  .Close (False)
End With

'arrFehlend redimensionieren
ReDim arrFehlend(lngLetzte, 3) As Variant

With ThisWorkbook.Worksheets("Stunden")
  'letzte beschriebene Zeile in Spalte A ermitteln
    lngLetzte = .Cells(Rows.Count, 1).End(xlUp).Row
   
    'Namen aus arrQuelle mit Namen in Tabelle vergleichen
    For n = LBound(arrQuelle, 1) To UBound(arrQuelle, 1)
       bGefunden = False       'Marker zurücksetzen
       'Namen nur bei Kostenstelle 1090 oder 4090 überprüfen
       If arrQuelle(n, 6) = arrKostenstellen(0) Or arrQuelle(n, 6) = arrKostenstellen(1) Then
         'aktuelle Tabelle durchlaufen
          For lngZeile = 8 To lngLetzte
           If .Cells(lngZeile, 1).Value = arrQuelle(n, 1) Then
             .Cells(lngZeile, 2) = arrQuelle(n, 2)  'Vorname in Spalte B
             .Cells(lngZeile, 3) = arrQuelle(n, 3)  'Pers. ID in Spalte C
             .Cells(lngZeile, 5) = arrQuelle(n, 6)  'Kostenstelle in Spalte E
             .Cells(lngZeile + 1, 5) = arrQuelle(n, 6) 'Kostenstelle in Spalte E eine Zeile tiefer
             bGefunden = True                   'Marker für gefunden
           End If
          Next lngZeile
          'falls nichts gefunden, dann Nachricht schreiben
          If bGefunden = False Then
            tMsg = tMsg & "Name: " & arrQuelle(n, 1) & ", Vorname: " & arrQuelle(n, 2) & ", Kostenstelle: " & arrQuelle(n, 6) & vbNewLine
            'und Daten in arrFehlend schreiben
            arrFehlend(f, 0) = arrQuelle(n, 1) 'Name
            arrFehlend(f, 1) = arrQuelle(n, 2) 'Vorname
            arrFehlend(f, 2) = arrQuelle(n, 3) 'Pers. ID
            arrFehlend(f, 3) = arrQuelle(n, 6) 'Kostenstellen
            'Zähler erhöhen
             f = f + 1
          End If
         End If
      Next n
 
    'Bildschirmaktualisierung einschalten:
     Application.ScreenUpdating = True

    ' Wenn es Abweichungen gibt, zeigen Sie eine MsgBox an
     If tMsg <> "" Then
        If MsgBox("Es gibt Abweichungen:" & vbNewLine & tMsg & vbNewLine & "Möchten Sie diese übernehmen?", vbYesNo) = vbYes Then
            ' Übernehmen Sie die Änderungen
          For k = 0 To 1
            'letzten Eintrag für Kostenstellen suchen
            With .Range("E:E")
             Set rngErgebnis = .Find(arrKostenstellen(k), LookIn:=xlValues, lookat:=xlWhole)
            End With
            
            If Not rngErgebnis Is Nothing Then
               lngZeile = rngErgebnis.Row
               'Schleife zum Suchen der nächsten Eintragszeile
                Do Until .Cells(lngZeile, 5) = ""
                  lngZeile = lngZeile + 1
                Loop
               Else
                'falls noch kein Eintrag vorhanden, dann unten einfügen
                lngZeile = .Cells(Rows.Count, 5).End(xlUp).Row + 10
              End If
             'Daten in Blatt schreiben
            For n = 0 To f - 1
             If arrFehlend(n, 3) = arrKostenstellen(k) Then
              '2 neue Zeilen einfügen
              .Rows(lngZeile & ":" & lngZeile + 1).Insert
              'Daten in Blatt schreiben
              .Cells(lngZeile, 1) = arrFehlend(n, 0)         'Name
              .Cells(lngZeile, 2) = arrFehlend(n, 1)          'Vorname
              .Cells(lngZeile, 3) = arrFehlend(n, 2)          'Pers.ID
              .Cells(lngZeile, 5) = arrFehlend(n, 3)          'Kostenstelle
              .Cells(lngZeile + 1, 5) = arrFehlend(n, 3)        'Kostenstelle
              'Rahmen
              With .Range(.Cells(lngZeile, 1), .Cells(lngZeile + 1, 16))
                 With .Borders(xlEdgeLeft)
                       .LineStyle = xlContinuous
                       .ColorIndex = 0
                       .TintAndShade = 0
                       .Weight = xlThin
                 End With
                 With .Borders(xlEdgeTop)
                   .LineStyle = xlContinuous
                   .ColorIndex = 0
                   .TintAndShade = 0
                   .Weight = xlThin
                 End With
                 With .Borders(xlEdgeBottom)
                   .LineStyle = xlContinuous
                   .ColorIndex = 0
                   .TintAndShade = 0
                   .Weight = xlThin
                 End With
                 With .Borders(xlEdgeRight)
                      .LineStyle = xlContinuous
                      .ColorIndex = 0
                      .TintAndShade = 0
                      .Weight = xlThin
                 End With
               End With
              End If
             Next n
            Next k
          End If
          'Datei speichern
          ThisWorkbook.Save
          
     End If
    
End With
End Sub

Gruß

M.O.

Answer 4

Einen sehr großen Dank an Sie...

Der VBA-Code funktioniert in der Dummy-Datei vorbildlich. Ich werde sie in der original Datei testen, denn sie hat 20 verschiedene Kostenstellen , und davon sieben Kostenstellen sind für die Aufgabe wichtig.

Answer 5

Besten Dank noch mal. 

Ohne Ihre Unterstützung hätte ich den Code nicht zum Laufen bringen können.

Ich musste den Code für meine Zwecke an zwei Zeilen modifizieren:

Vorher :

'Namen nur bei Kostenstelle 1090 oder 4090 überprüfen
       If arrQuelle(n, 6) = arrKostenstellen(0) Or arrQuelle(n, 6) = arrKostenstellen(1) Then

Jetzt :

'Namen nur bei definierten Kostenstellen überprüfen
   For k = LBound(arrKostenstellen) To UBound(arrKostenstellen)
     If arrQuelle(n, 5) = arrKostenstellen(k) Then

...........

'Zähler erhöhen
           f = f + 1
        End If
       End If
     Next k  'Neu dazu gekommen.
  Next n

Da ich im Arbeitsblatt für den Bereich 5 Kst.(einige haben 8 Kst.) habe:

Vorher :

' Übernehmen Sie die Änderungen
          For k = 0 To 1

Jetzt:

' Übernehmen Sie die Änderungen
          For k = 0 To 4