RE: Übernahme Personendaten Tab1&2. Fehler

https://www.herber.de/bbs/user/165204.xls

Oben genannte Excel-Datei hat folgenden Fehler:
Sofern in Tab1 von Dienstag-Sonntag Namen ausgewählt werden und ihnen Funktionen zugeteilt werden, werden leider in den Einsatzplänen für Dienstag-Sonntag ausschließlich die Daten aus Montag eingetragen. Sind demnach Montag Personendaten ausgewählt, werden diese fälschlicherweise übernommen.

Ich hoffe auf. In Tabelle1, Modui1,2,3 sind Codes hinterlegt, welche vom Kollegen Piet hier aus dem Forum erstellt sind. Leider gehen meine VBA Kenntnisse gegen 0, sodass ich den Fehler nicht selbst beheben, oder diesem auf den Grund gehen kann. In Modul3 (Mitarbeiter_zuweisen_WochenTag())
findet sich jedoch der Code, welcher die Daten von Tabelle1 auf die Wochentage weiterleitet.

Anbei die Codes:

Tabelle1

Option Explicit    'Targret Code in Tabelle1

Dim rw As Integer, Zeile As Integer

Dim i As Integer, sp As Integer, Txt





Private Sub Worksheet_Change(ByVal Target As Range)

If InStr(Target.Address, ":") Then Exit Sub

If Target.Value = Empty Then Exit Sub

If Target.Column  3 Then Exit Sub

If Target.Column > 9 Then Exit Sub

   rw = Target.Row     'Target Zeile

   Txt = Target.Value  'Wert

   

If rw = 3 And Target.Value > "#" Then

   If Left(Txt, 1) = Right(Txt, 1) Then

      TagSht = Cells(1, Target.Column)

      Call Mitarbeiter_zuweisen_WochenTag

      'Wochentag Sheet Select

       Worksheets(TagSht).Select

   ElseIf Txt = "Alle" Then

      sp = Target.Column

      For i = 3 To 9

          TagSht = Worksheets("Tabelle1").Cells(1, i)

          Call Mitarbeiter_zuweisen_WochenTag

      Next i

      'Wochentag Sheet Select

      TagSht = Cells(1, sp)

      Worksheets(TagSht).Select

   End If

   Target.Value = Empty

   Exit Sub

End If



If rw = 3 Or rw = 9 Or rw = 19 Or rw = 29 Or rw = 39 Then

   On Error GoTo Fehler

   Target.Value = Empty

   If Txt > "#" Then Exit Sub

   sp = Target.Column: Zeile = 4

   If rw > 3 Then Zeile = 8

   

   Application.EnableEvents = False

   'neue Spalte aus vorheriger füllen

   For i = 1 To Zeile

       If Cells(rw + i, sp - 1) > "" Then

          Cells(rw + i, sp) = Cells(rw + i, sp - 1)

       End If

   Next i

   Application.EnableEvents = True

End If

Exit Sub



Fehler:  Application.EnableEvents = True

MsgBox "Unerwarteter Target Fehler"

End Sub

Modul1

Option Explicit      '5.12.2023  Piet  für Herber Forum









Sub Mitarbeiter_zuweisen()

Dim AC As Range, i As Integer

Dim Tb2 As Worksheet, n As Long

Set Tb2 = Worksheets("Tabelle2")



With Worksheets("Tabelle1")

     'Zugführung auswerten

     For Each AC In .Range("ZFBereich")

         If InStr(AC.Offset(0, 1), "EINSATZ I ZF") Then

            Tb2.Range("B12").Value = AC.Value

         ElseIf InStr(AC.Offset(0, 1), "Stellv. ZF") Then

            Tb2.Range("B13").Value = AC.Value

         ElseIf InStr(AC.Offset(0, 1), "Fahrer ZF") Then

            Tb2.Range("B14").Value = AC.Value

         End If

     Next AC

     

     i = 1    '1. Gruppe auswerten

     For Each AC In .Range("Gruppe1")

         If InStr(AC.Offset(0, 1), "EINSATZ I GF") Then

            Tb2.Range("B21").Value = AC.Value

         ElseIf InStr(AC.Offset(0, 1), "Stellv. GF") Then

            Tb2.Range("B22").Value = AC.Value

         ElseIf InStr(AC.Offset(0, 1), "EINSATZ I") Then

            Tb2.Range("B23").Cells(i, 1) = AC.Value

            i = i + 1

         End If

     Next AC

     

     i = 1    '2. Gruppe auswerten

     For Each AC In .Range("Gruppe2")

         If InStr(AC.Offset(0, 1), "EINSATZ I GF") Then

            Tb2.Range("G21").Value = AC.Value

         ElseIf InStr(AC.Offset(0, 1), "Stellv. GF") Then

            Tb2.Range("G22").Value = AC.Value

         ElseIf InStr(AC.Offset(0, 1), "EINSATZ I") Then

            Tb2.Range("G23").Cells(i, 1) = AC.Value

            i = i + 1

         End If

     Next AC

     

     i = 1    '3. Gruppe auswerten

     For Each AC In .Range("Gruppe3")

         If InStr(AC.Offset(0, 1), "EINSATZ I GF") Then

            Tb2.Range("B35").Value = AC.Value

         ElseIf InStr(AC.Offset(0, 1), "Stellv. GF") Then

            Tb2.Range("B36").Value = AC.Value

         ElseIf InStr(AC.Offset(0, 1), "EINSATZ I") Then

            Tb2.Range("B37").Cells(i, 1) = AC.Value

            i = i + 1

         End If

     Next AC

     

     i = 1    '4. Gruppe auswerten

     For Each AC In .Range("Gruppe4")

         If InStr(AC.Offset(0, 1), "EINSATZ I GF") Then

            Tb2.Range("G35").Value = AC.Value

         ElseIf InStr(AC.Offset(0, 1), "Stellv. GF") Then

            Tb2.Range("G36").Value = AC.Value

         ElseIf InStr(AC.Offset(0, 1), "EINSATZ I") Then

            Tb2.Range("G37").Cells(i, 1) = AC.Value

            i = i + 1

         End If

     Next AC

End With

End Sub

Modul2

Option Explicit









Sub Adressentest()

Dim Txt As String

On Error GoTo Fehler

Worksheets("Tabelle1").Select

Range("ZFBereich").Select

Txt = "Zugführung":  GoSub AdrShow

Range("Gruppe1").Select

Txt = "Gruppe 1":   GoSub AdrShow

Range("Gruppe2").Select

Txt = "Gruppe 2":   GoSub AdrShow

Range("Gruppe3").Select

Txt = "Gruppe 3":   GoSub AdrShow

Range("Gruppe4").Select

Txt = "Gruppe 4":   GoSub AdrShow

Application.CutCopyMode = False

[b1].Select

Exit Sub



AdrShow:  Selection.Copy

         MsgBox Selection.Address(0, 0) & vbLf & Txt:  Return

Fehler:  MsgBox Txt & "  Fehler bei dieser Adresse, bitte prüfen"

Application.CutCopyMode = False

End Sub

Modul3

Option Explicit          '5.12.2023  Piet  für Herber Forum

Public TagSht As String  'Tages Tabelle







Sub Mitarbeiter_zuweisen_WochenTag()

Dim AC As Range, Sht As String, arrWTag

Dim TbX As Worksheet, i As Integer

   'Tabellen für alle Tage:  Montag bis Sonntag

   Set TbX = Worksheets(TagSht)    'Zielsheet Mo-So.

   

   'alte Tabellenbereiche löschen

   TbX.Range("B12:B14").ClearContents

   TbX.Range("B21:B28").ClearContents

   TbX.Range("G21:G28").ClearContents

   TbX.Range("B35:B42").ClearContents

   TbX.Range("G35:G42").ClearContents



With Worksheets("Tabelle1")

     'Zugführung auswerten

     For Each AC In .Range("ZFBereich")

         If InStr(AC.Offset(0, 1), "EINSATZ I ZF") Then

            TbX.Range("B12").Value = AC.Value

         ElseIf InStr(AC.Offset(0, 1), "Stellv. ZF") Then

            TbX.Range("B13").Value = AC.Value

         ElseIf InStr(AC.Offset(0, 1), "Fahrer ZF") Then

            TbX.Range("B14").Value = AC.Value

         End If

     Next AC

     

     i = 1    '1. Gruppe auswerten

     For Each AC In .Range("Gruppe1")

         If InStr(AC.Offset(0, 1), "EINSATZ I GF") Then

            TbX.Range("B21").Value = AC.Value

         ElseIf InStr(AC.Offset(0, 1), "Stellv. GF") Then

            TbX.Range("B22").Value = AC.Value

         ElseIf InStr(AC.Offset(0, 1), "EINSATZ I") Then

            TbX.Range("B23").Cells(i, 1) = AC.Value

            i = i + 1

         End If

     Next AC

     

     i = 1    '2. Gruppe auswerten

     For Each AC In .Range("Gruppe2")

         If InStr(AC.Offset(0, 1), "EINSATZ I GF") Then

            TbX.Range("G21").Value = AC.Value

         ElseIf InStr(AC.Offset(0, 1), "Stellv. GF") Then

            TbX.Range("G22").Value = AC.Value

         ElseIf InStr(AC.Offset(0, 1), "EINSATZ I") Then

            TbX.Range("G23").Cells(i, 1) = AC.Value

            i = i + 1

         End If

     Next AC

     

     i = 1    '3. Gruppe auswerten

     For Each AC In .Range("Gruppe3")

         If InStr(AC.Offset(0, 1), "EINSATZ I GF") Then

            TbX.Range("B35").Value = AC.Value

         ElseIf InStr(AC.Offset(0, 1), "Stellv. GF") Then

            TbX.Range("B36").Value = AC.Value

         ElseIf InStr(AC.Offset(0, 1), "EINSATZ I") Then

            TbX.Range("B37").Cells(i, 1) = AC.Value

            i = i + 1

         End If

     Next AC

     

     i = 1    '4. Gruppe auswerten

     For Each AC In .Range("Gruppe4")

         If InStr(AC.Offset(0, 1), "EINSATZ I GF") Then

            TbX.Range("G35").Value = AC.Value

         ElseIf InStr(AC.Offset(0, 1), "Stellv. GF") Then

            TbX.Range("G36").Value = AC.Value

         ElseIf InStr(AC.Offset(0, 1), "EINSATZ I") Then

            TbX.Range("G37").Cells(i, 1) = AC.Value

            i = i + 1

         End If

     Next AC

End With

End Sub

Vielen Dank fürs zuhören und danke im Voraus für jegliche Hilfe!

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit '5.12.2023 Piet für Herber Forum Public TagSht As String 'Tages Tabelle Public TagCol As String 'Tages Column '** Korrektur 19.12.23 'Spalten Offset Sub Mitarbeiter_zuweisen_WochenTag() Dim AC As Range, Sht As String, arrWTag Dim TbX As Worksheet, i As Integer, sp As Integer 'Tabellen für alle Tage: Montag bis Sonntag Set TbX = Worksheets(TagSht) 'Zielsheet Mo-So. 'alte Tabellenbereiche löschen TbX.Range("B12:B14").ClearContents TbX.Range("B21:B28").ClearContents TbX.Range("G21:G28").ClearContents TbX.Range("B35:B42").ClearContents TbX.Range("G35:G42").ClearContents With Worksheets("Tabelle1") '** Korrektur 19.12.23 '** Tages Spalte ermitteln für Spalten Offset(0,sp) For sp = 3 To 9 If TagSht = .Cells(1, sp) Then sp = sp - 2: Exit For Next sp 'Zugführung auswerten For Each AC In .Range("ZFBereich") If InStr(AC.Offset(0, sp), "EINSATZ I ZF") Then TbX.Range("B12").Value = AC.Value ElseIf InStr(AC.Offset(0, sp), "Stellv. ZF") Then TbX.Range("B13").Value = AC.Value ElseIf InStr(AC.Offset(0, sp), "Fahrer ZF") Then TbX.Range("B14").Value = AC.Value End If Next AC i = 1 '1. Gruppe auswerten For Each AC In .Range("Gruppe1") If InStr(AC.Offset(0, sp), "EINSATZ I GF") Then TbX.Range("B21").Value = AC.Value ElseIf InStr(AC.Offset(0, sp), "Stellv. GF") Then TbX.Range("B22").Value = AC.Value ElseIf InStr(AC.Offset(0, sp), "EINSATZ I") Then TbX.Range("B23").Cells(i, 1) = AC.Value i = i + 1 End If Next AC i = 1 '2. Gruppe auswerten For Each AC In .Range("Gruppe2") If InStr(AC.Offset(0, sp), "EINSATZ I GF") Then TbX.Range("G21").Value = AC.Value ElseIf InStr(AC.Offset(0, sp), "Stellv. GF") Then TbX.Range("G22").Value = AC.Value ElseIf InStr(AC.Offset(0, sp), "EINSATZ I") Then TbX.Range("G23").Cells(i, 1) = AC.Value i = i + 1 End If Next AC i = 1 '3. Gruppe auswerten For Each AC In .Range("Gruppe3") If InStr(AC.Offset(0, sp), "EINSATZ I GF") Then TbX.Range("B35").Value = AC.Value ElseIf InStr(AC.Offset(0, sp), "Stellv. GF") Then TbX.Range("B36").Value = AC.Value ElseIf InStr(AC.Offset(0, sp), "EINSATZ I") Then TbX.Range("B37").Cells(i, 1) = AC.Value i = i + 1 End If Next AC i = 1 '4. Gruppe auswerten For Each AC In .Range("Gruppe4") If InStr(AC.Offset(0, sp), "EINSATZ I GF") Then TbX.Range("G35").Value = AC.Value ElseIf InStr(AC.Offset(0, sp), "Stellv. GF") Then TbX.Range("G36").Value = AC.Value ElseIf InStr(AC.Offset(0, sp), "EINSATZ I") Then TbX.Range("G37").Cells(i, 1) = AC.Value i = i + 1 End If Next AC End With End Sub

Beliebteste Forumthreads (12 Monate)

RE: Übernahme Personendaten Tab1&2. Fehler

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

RE: Übernahme Personendaten Tab1&2. Fehler

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread