Live-Forum - Die aktuellen Beiträge
Datum
Titel
19.04.2024 13:49:38
Per Kopfdruck als pdf speichern und Mail erstellen
19.04.2024 12:58:59
Daten einfügen aus anderem Sheet
19.04.2024 12:23:24
Wenn-Formel anpassen
19.04.2024 12:09:19
Unique (Application.WorksheetFunction.Unique)
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1668to1672
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1668to1672
1668to1672
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Einen Bereich auslesen und als Listeneintrag erf.

Einen Bereich auslesen und als Listeneintrag erf.
27.01.2019 20:52:57
Alex
https://www.herber.de/bbs/user/127189.xlsx
Hallo in der Beispieldatei handelt es sich um eine Personal-Planungstafel,
leider kann ich sie durch die Datenbegrenzung nicht Vollständig auf den Server laden.
Die Datei besteht aus dem Tabellenblatt "Personalplanung" und "Transfer",
mein Problem der Transfer beansprucht sehr viel Zeit... Aktuell hab ich eine = Verküpfung auf die Zelle der Anlage, Person, Zeit pro Anlage.Es gibt pro Anlage 2 Zellen obere für 7,5 Std. geplant untere Ablöse 0,5 Std. das ganze wiederspiegelt sich in der Transferliste. Die Liste aus dem Tabellenblatt "Transfer" wird durch dass drücken des Button Daten Übertragung in eine Access DB übertragen.
Kann man anstatt der = Verküpfung per VBA die belegten Zellen auslesen und so in die Transferliste eintragen lassen, so dass wenn kein Personal gesetzt ist die Zellen wegfallen würen ? und nach dem Transfer wieder eine Reset erhält der Liste.

12
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Einen Bereich auslesen und als Listeneintrag erf.
29.01.2019 00:05:19
fcs
Hallo Alex,
probiere mal, ob das folgende Makro wie gewünscht die Daten überträgt.
LG
Franz 

Sub Daten_nach_Transfer()
Dim wksPlan As Worksheet, wksTransfer As Worksheet
Dim zeiP As Long, spaP As Long
Dim zeiPL As Long, spaPL As Long
Dim zeiT As Long
Dim sSchicht As String, datDatum As Date
Dim StatusCalc As Long
Set wksPlan = ActiveWorkbook.Worksheets("Personalplanung")
Set wksTransfer = ActiveWorkbook.Worksheets("Transfer (2)")
'Makrobrmsen lösen
With Application
.ScreenUpdating = False
.EnableEvents = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
End With
With wksTransfer
'Alte daten im Blatt Transfer löschen
zeiT = .Cells(.Rows.Count, 1).End(xlUp).Row
If zeiT > 1 Then
.Range(.Cells(2, 1), .Cells(zeiT, 6)).ClearContents
End If
zeiT = 1
End With
With wksPlan
'letzte Zeile mit Daten in Spalte H
zeiPL = .Cells(.Rows.Count, 8).End(xlUp).Row
'letzte Spalte mit Mitarbiter-Zuordnung zu Anlage
spaPL = .Range("BE11").Column
sSchicht = .Range("AJ8").Value
datDatum = .Range("AJ6").Value
For spaP = 8 To spaPL Step 7
For zeiP = 11 To zeiPL Step 4
If .Cells(zeiP, spaP).Offset(1, 0).Value  "" Then
zeiT = zeiT + 1
wksTransfer.Cells(zeiT, 1) = sSchicht
wksTransfer.Cells(zeiT, 2) = datDatum
wksTransfer.Cells(zeiT, 3) = .Cells(zeiP, spaP).Offset(1, 3).Value 'Anlage
wksTransfer.Cells(zeiT, 5) = .Cells(zeiP, spaP).Offset(1, 0).Value 'MA
wksTransfer.Cells(zeiT, 6) = .Cells(zeiP, spaP).Offset(1, 2).Value 'Zeit
End If
If .Cells(zeiP, spaP).Offset(2, 0).Value  "" Then
zeiT = zeiT + 1
wksTransfer.Cells(zeiT, 1) = sSchicht
wksTransfer.Cells(zeiT, 2) = datDatum
wksTransfer.Cells(zeiT, 3) = .Cells(zeiP, spaP).Offset(2, 3).Value 'Anlage
wksTransfer.Cells(zeiT, 5) = .Cells(zeiP, spaP).Offset(2, 0).Value 'MA
wksTransfer.Cells(zeiT, 6) = .Cells(zeiP, spaP).Offset(2, 2).Value 'Zeit
End If
Next
Next
End With
'Makrobrmsen zurücksetzen
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = StatusCalc
End With
End Sub

Anzeige
AW: Einen Bereich auslesen und als Listeneintrag erf.
29.01.2019 10:42:20
Alex
Sieht gut aus, was mir auffällt er gibt das Datum 2 mal aus.
Tabellenblatt Transfer Spalte F unter Zeit trägt er das Datum ein,
eigentlich sollte hier aus der Personalplanung Spalte I die Zeit ausgelesen werden.
Kann mann die Kategorieleitse weglassen und die Einträge ab Zeile 3 starten ?
AW: Einen Bereich auslesen und als Listeneintrag erf.
29.01.2019 10:44:20
Alex
ich meinte natürlich nicht nur Spalte I sondern auf den ganzen Bereich die Zeitangaben neben den Mitarbeitern 7,5 und 0,5
AW: Einen Bereich auslesen und als Listeneintrag erf.
29.01.2019 10:47:57
Alex
For spaP = 8 To spaPL Step 7
For zeiP = 11 To zeiPL Step 4
If .Cells(zeiP, spaP).Offset(1, 0).Value "" Then
zeiT = zeiT + 1
wksTransfer.Cells(zeiT, 1) = sSchicht
wksTransfer.Cells(zeiT, 2) = datDatum
wksTransfer.Cells(zeiT, 3) = .Cells(zeiP, spaP).Offset(1, 3).Value 'Anlage
wksTransfer.Cells(zeiT, 5) = .Cells(zeiP, spaP).Offset(1, 0).Value 'MA
wksTransfer.Cells(zeiT, 6) = .Cells(zeiP, spaP).Offset(1, 1).Value 'Zeit
End If
If .Cells(zeiP, spaP).Offset(2, 0).Value "" Then
zeiT = zeiT + 1
wksTransfer.Cells(zeiT, 1) = sSchicht
wksTransfer.Cells(zeiT, 2) = datDatum
wksTransfer.Cells(zeiT, 3) = .Cells(zeiP, spaP).Offset(2, 3).Value 'Anlage
wksTransfer.Cells(zeiT, 5) = .Cells(zeiP, spaP).Offset(2, 0).Value 'MA
wksTransfer.Cells(zeiT, 6) = .Cells(zeiP, spaP).Offset(2, 1).Value 'Zeit
Habe die Werte der Zeit auf 1 gesetzt, denke dass ist richtig so.
Anzeige
AW: Einen Bereich auslesen und als Listeneintrag erf.
29.01.2019 14:43:40
fcs
Hallo Alex,
der Fehler beim Offset für die Zeitspalte ist mir in der Eile durchgerutscht. Hast du ja selber hinbekommen.
Die Zeile mit den Kategorien kannst du weglassen.
Startzeile für das Eintragen kann man anpassen.
Hab es per Konstante gelöst,
LG
Franz 
Sub Daten_nach_Transfer()
Dim wksPlan As Worksheet, wksTransfer As Worksheet
Dim zeiP As Long, spaP As Long
Dim zeiPL As Long, spaPL As Long
Dim zeiT As Long
Dim sSchicht As String, datDatum As Date
Dim StatusCalc As Long
Const zeiStart = 3 '1. Zeile in die Transferdaten eingetragenn werden sollen
Set wksPlan = ActiveWorkbook.Worksheets("Personalplanung")
Set wksTransfer = ActiveWorkbook.Worksheets("Transfer")
'Makrobremsen lösen
With Application
.ScreenUpdating = False
.EnableEvents = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
End With
With wksTransfer
'Alte daten im Blatt Transfer löschen
zeiT = .Cells(.Rows.Count, 1).End(xlUp).Row
If zeiT >= zeiStart Then
.Range(.Cells(zeiStart, 1), .Cells(zeiT, 6)).ClearContents
End If
zeiT = zeiStart - 1
End With
With wksPlan
'letzte Zeile mit Daten in Spalte H
zeiPL = .Cells(.Rows.Count, 8).End(xlUp).Row
'letzte Spalte mit Mitarbiter-Zuordnung zu Anlage
spaPL = .Range("BE11").Column
sSchicht = .Range("AJ8").Value
datDatum = .Range("AJ6").Value
For spaP = 8 To spaPL Step 7
For zeiP = 11 To zeiPL Step 4
If .Cells(zeiP, spaP).Offset(1, 0).Value  "" Then
zeiT = zeiT + 1
wksTransfer.Cells(zeiT, 1) = sSchicht
wksTransfer.Cells(zeiT, 2) = datDatum
wksTransfer.Cells(zeiT, 3) = .Cells(zeiP, spaP).Offset(1, 3).Value 'Anlage
wksTransfer.Cells(zeiT, 5) = .Cells(zeiP, spaP).Offset(1, 0).Value 'MA
wksTransfer.Cells(zeiT, 6) = .Cells(zeiP, spaP).Offset(1, 1).Value 'Zeit
End If
If .Cells(zeiP, spaP).Offset(2, 0).Value  "" Then
zeiT = zeiT + 1
wksTransfer.Cells(zeiT, 1) = sSchicht
wksTransfer.Cells(zeiT, 2) = datDatum
wksTransfer.Cells(zeiT, 3) = .Cells(zeiP, spaP).Offset(2, 3).Value 'Anlage
wksTransfer.Cells(zeiT, 5) = .Cells(zeiP, spaP).Offset(2, 0).Value 'MA
wksTransfer.Cells(zeiT, 6) = .Cells(zeiP, spaP).Offset(2, 1).Value 'Zeit
End If
Next
Next
End With
'Makrobremsen zurücksetzen
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = StatusCalc
End With
End Sub

Anzeige
AW: Einen Bereich auslesen und als Listeneintrag erf.
29.01.2019 20:00:35
Alex
Vielen Dank, ich werde den Code jetzt mal in meine Orginal Datei mmit einbinden.
Mal sehen ob der Datentransfer durch das ausgliedern der nicht gesetzten Anlagen schneller funktioniert. Das ist mein Code der die Liste dann überträgt, evtl. siehst du noch was was man optimieren könnte :)
Sub DatenInAccessDB()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
Range("B22") = Now
Makro4
Dim MsgText As String
Dim db As DAO.Database, rs As DAO.Recordset, SQL As String
On Error GoTo Err_Handler
If WorksheetFunction.CountIf(Worksheets("ErfassungEinstätze").Columns("C:C"), Date) = 0 Then
sDataBaseFile = Worksheets("Setting").Cells(2, 3).Value
SQL = "Select * From " & Worksheets("Setting").Cells(2, 4).Value & " Where ID Is Null;"
Set db = OpenDatabase(sDataBaseFile)
While Worksheets("DB_Transfer").Cells(3, 1).Value  ""
SQL = "Select * From " & Worksheets("Setting").Cells(2, 4).Value & " Where ID Is Null;"
Set rs = db.OpenRecordset(SQL)
With rs
.AddNew
For i = 1 To Worksheets("Setting").Cells(2, 5).Value
.Fields(Worksheets("DB_Transfer").Cells(2, i).Value) = _
Worksheets("DB_Transfer").Cells(3, i).Value
Next
.Fields("Frei20") = Worksheets("DB_Transfer").Cells(3, 25).Value
.Update
End With
Worksheets("DB_Transfer").Rows("3:3").Delete Shift:=xlUp
Worksheets("PERSONALPLANUNG").Cells(22, 2).Interior.Color = RGB(0, 255, 128)
rs.Close
Wend
db.Close
Else
Beep
MsgBox "Datentransfer für den " & Date & " ist schon erfolgt.", Buttons:=vbInformation
End If
End_Handler:
Set rs = Nothing
Set db = Nothing
Exit Sub
Err_Handler:
Worksheets("DB_Transfer").Cells(1, 1).Interior.Color = RGB(204, 0, 0)
msgNetzwerkfehler
Resume End_Handler
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
Makro7
save
End Sub

Anzeige
AW: Einen Bereich auslesen und als Listeneintrag erf.
30.01.2019 09:02:16
fcs
Hallo alex,
wahrscheinlich geht es schneller wenn man in der While-Wend-Schleife einen Zeilenzähler von 3 aufsteigend hochzahlt und die Daten der jeweiligen Zeile nach Access überträgt, statt jedesmal am Ende der Schleife die abgearbeitetete Zeile 3 zu löschen und die Daten nach oben aufrücken zulassen.
Man kann dann nach der Wend-Zeile alle eingelesenen Zeilen in einem Rutsch löschen.
LG
Franz
AW: Einen Bereich auslesen und als Listeneintrag erf.
30.01.2019 11:53:50
Alex
Zu deinem Code habe ich noch eine Frage, wenn ich bei Sonstiges Mitarbeiter definiere wird keine Zeit und keine Anlage dazu angezeigt. was muss geändert werden um den Bereich zu erweitern ?
Anzeige
AW: Einen Bereich auslesen und als Listeneintrag erf.
30.01.2019 20:54:57
Alex
Hmm unten bei Sonstiges Urlaub Abwesend scheint dein Code einen Fehler zu haben, teilweise zeigt er sie nicht an oder es ist keine Zugehörigkeit der Anlage dabei.
AW: Einen Bereich auslesen und als Listeneintrag erf.
31.01.2019 09:40:35
Alex
Ich denke ich habs verstanden :D, hat wohl mit der Aufteilung der unteren Zellen zu tun zwischen Zeilen zu den nächsten Mitarbeiter usw, außerdem waren noch verbundene Zellen darin enthalten.
Das mit der DatenInAccessDB hab ich etwas rumprobiert,aber komme auf keinen grünen Zweig.
Bekomme dann immer nur Zeile 1 übertragen wenn ich den delet Befehl lösche.
wie sage ich dem ganzen nun wie du das beschrieben hast mit "Zeilenzähler von 3 aufsteigend hochzählt " 
Sub DatenInAccessDB()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
Range("B22") = Now
Makro4
Dim MsgText As String
Dim db As DAO.Database, rs As DAO.Recordset, SQL As String
On Error GoTo Err_Handler
If WorksheetFunction.CountIf(Worksheets("ErfassungEinstätze").Columns("C:C"), Date) = 0 Then
sDataBaseFile = Worksheets("Setting").Cells(2, 3).Value
SQL = "Select * From " & Worksheets("Setting").Cells(2, 4).Value & " Where ID Is Null;"
Set db = OpenDatabase(sDataBaseFile)
While Worksheets("DB_Transfer").Cells(3, 1).Value  ""
SQL = "Select * From " & Worksheets("Setting").Cells(2, 4).Value & " Where ID Is Null; _
Set rs = db.OpenRecordset(SQL)
With rs
.AddNew
For i = 1 To Worksheets("Setting").Cells(2, 5).Value
.Fields(Worksheets("DB_Transfer").Cells(2, i).Value) = _
Worksheets("DB_Transfer").Cells(3, i).Value
Next
.Fields("Frei20") = Worksheets("DB_Transfer").Cells(3, 25).Value
.Update
End With
Worksheets("DB_Transfer").Rows("3:3").Delete Shift:=xlUp
Worksheets("PERSONALPLANUNG").Cells(22, 2).Interior.Color = RGB(0, 255, 128)
rs.Close
Wend
db.Close
Else
Beep
MsgBox "Datentransfer für den " & Date & " ist schon erfolgt.", Buttons:=vbInformation
End If
End_Handler:
Set rs = Nothing
Set db = Nothing
Exit Sub
Err_Handler:
Worksheets("DB_Transfer").Cells(1, 1).Interior.Color = RGB(204, 0, 0)
msgNetzwerkfehler
Resume End_Handler
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
Makro7
save
End Sub

Anzeige
AW: Einen Bereich auslesen und als Listeneintrag erf.
31.01.2019 20:08:56
fcs
Hallo Alex,
probiere es mal wie folgt.
Das Ende des Makros musst du auch umbauen, damit diese Zeilen auch abgearbeitet werden.
LG
Franz 
Sub DatenInAccessDB()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
Range("B22") = Now
Makro4
Dim MsgText As String
Dim db As DAO.Database, rs As DAO.Recordset, SQL As String
Dim zeile As Long
On Error GoTo Err_Handler
If WorksheetFunction.CountIf(Worksheets("ErfassungEinstätze").Columns("C:C"), Date) = 0 Then
sDataBaseFile = Worksheets("Setting").Cells(2, 3).Value
SQL = "Select * From " & Worksheets("Setting").Cells(2, 4).Value & " Where ID Is Null;"
Set db = OpenDatabase(sDataBaseFile)
zeile = 3
While Worksheets("DB_Transfer").Cells(zeile, 1).Value  ""
SQL = "Select * From " & Worksheets("Setting").Cells(2, 4).Value _
& " Where ID Is Null;"
Set rs = db.OpenRecordset(SQL)
With rs
.AddNew
For i = 1 To Worksheets("Setting").Cells(2, 5).Value
.Fields(Worksheets("DB_Transfer").Cells(2, i).Value) = _
Worksheets("DB_Transfer").Cells(zeile, i).Value
Next
.Fields("Frei20") = Worksheets("DB_Transfer").Cells(zeile, 25).Value
.Update
End With
Worksheets("PERSONALPLANUNG").Cells(22, 2).Interior.Color = RGB(0, 255, 128)
rs.Close
zeile = zeile + 1
Wend
Worksheets("DB_Transfer").Rows("3:" & zeile).Delete Shift:=xlUp
db.Close
Else
Beep
MsgBox "Datentransfer für den " & Date & " ist schon erfolgt.", Buttons:=vbInformation
End If
End_Handler:
Set rs = Nothing
Set db = Nothing
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
Makro7    '?
Save
Exit Sub
Err_Handler:
Worksheets("DB_Transfer").Cells(1, 1).Interior.Color = RGB(204, 0, 0)
msgNetzwerkfehler
Resume End_Handler
End Sub

Anzeige
AW: Einen Bereich auslesen und als Listeneintrag erf.
01.02.2019 09:14:55
Alex
Vielen Vielen Dank, dmait ist die Sache abgeschlossen läuft perfekt. Daumen hoch :)

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige