Reupload: Übernahme Personendaten Tab1&2. VBA-Fragen
11.12.2023 18:22:42
Daenzn
Im letzten Beitrag, der nun leider im Archiv gelandet ist, konnte mir einer von euch (Piet), mega gut helfen. Aktuell gibt es nun leider das ein oder andere "Problemchen" bei den Codes. Ich habe gewisse Änderungen vorgenommen an den Tabellen (hinsichtlich Beizeichnungen, Datenüberprüfungen, erweiterung der Tabellen von 4 auf 7 Tage).
Zunächst einmal die Codes/Makros:
Tabelle1:
Option Explicit
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
If rw = 3 And Txt > "#" And _
Left(Txt, 1) = Right(Txt, 1) Then
Target.Value = Empty
TagSpa = Target.Column
Call Mitarbeiter_zuweisen_WochenTag
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
In diesem Fall gibt es ein paar Probleme mit dem "Kurzbefehl": Eintragen/ oder eher gesat, dass die ausgewählten Namen in den entsprechenden Tabellen landen.
Das übertragen der Namen mittels # funktioniert problemlos.
Modul1 Mitarbeiter_Zuweisen:
Hier kann ich keinen fehler etecken.
Modul2 Adressentest:
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
Code funktioniert problemlos.
Modul3 Mitarbeiter_Zuweisen_WochenTag
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
arrWTag = Array("Montag", "Dienstag", "Mittwoch", "Donnerstag", "Freitag", "Samstag", "Sonntag")
Sht = arrWTag(TagSpa - 3) 'Target Spalte-3
Set TbX = Worksheets(Sht) '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 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 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") 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 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") 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 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") 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 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") Then
TbX.Range("G37").Cells(i, 1) = AC.Value
i = i + 1
End If
Next AC
End With
'Wochentag Sheet Select
Worksheets(Sht).Select
End Sub
Code funktionierte anfänglich. Bis ich die Daten aus der Datenüberprüfung verändert habe. Zudem habe ich das Array vervollständigt, welches nur bis Mi, Do. ging.
Aktuell wird ein Laufzeitfehler bei:
'Tabellen für alle Tage: Montag bis Sonntag
arrWTag = Array("Montag", "Dienstag", "Mittwoch", "Donnerstag", "Freitag", "Samstag", "Sonntag")
Sht = arrWTag(TagSpa - 3) 'Target Spalte-3
Set TbX = Worksheets(Sht) 'Zielsheet Mo-So.Ich habe die Excel Datei mitverlinkt. Ich hoffe ihr könnt mir weiterhelfen.
Speziell hoffe ich: Hey Piet, falls du die möglichkeit besitzt, würde ich ich freuen wenn du ir weiterhelen
Grüße:
Daenzn!!
https://www.herber.de/bbs/user/165001.xlsm