Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1524to1528
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
Inhaltsverzeichnis

Prüfzeile einbinden

Prüfzeile einbinden
15.11.2016 12:51:15
Berndt
Hallo zusammen,
mit folgenden langen Code übertrage ich verschiedene Spalten von mehreren Sheets in ein Sheet zusammenfassend.
Sub Aufgabenübertragung()
Dim wksZiel As Worksheet
Dim wksQuelle As Worksheet
Dim Zeile_1_Z&, Zeile_1_Q&, Zeile_Z&, Zeile_Q&, AnzahlZeilen&
Dim rngCopy As Range
Dim StatusCalc As Long
Dim Lastaf2 As Long
Dim lngT As Long
Set wksZiel = Worksheets("Dashboard")
'Makrobremsen lösen
With Application
.ScreenUpdating = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
End With
'Altdaten in Zieltabelle löschen
With wksZiel
Zeile_1_Z = .Range("Zelle_Name").Row + 1
If .Cells(Zeile_1_Z, 4) = "" Then
'keine Daten unter Titelzeile in SPalte D eingetragen-->keine Altdaten vorhanden
Else
'Letzte Zeile mit Aufgabe
Zeile_Z = .Cells(Zeile_1_Z - 1, 4).End(xlDown).Row
'Zeilen löschen
.Range(.Rows(Zeile_1_Z), .Rows(Zeile_Z)).Delete Shift:=xlShiftUp
End If
Zeile_Z = Zeile_1_Z
End With
'Tabellen abarbeiten
For Each wksQuelle In ActiveWorkbook.Worksheets
'Anfang des Blattnamens prüfen
If (UCase(wksQuelle.Name) Like "*HERR*" Or UCase(wksQuelle.Name) Like "*FRAU*") Then
With wksQuelle
Zeile_1_Q = 8
If .Cells(Zeile_1_Q, 2).Text  "" Then
'Zeile mit letzter Aufgabe in Spalte B
Zeile_Q = .Cells(Zeile_1_Q - 1, 2).End(xlDown).Row
Else
'keine Aufgabe vorhanden
Zeile_Q = Zeile_1_Q
End If
AnzahlZeilen = Zeile_Q - Zeile_1_Q + 1
End With
With wksZiel
'Leerzeilen für Name einfügen
.Range(.Rows(Zeile_Z), .Rows(Zeile_Z + AnzahlZeilen - 1)).Insert
'Name in Spalte B eintragen
.Cells(Zeile_Z, 2) = wksQuelle.Name
End With
With wksQuelle
lngT = DateSerial(Year(Datum + (8 - Weekday(Datum)) Mod 7 - 3), 1, 1)
DINKw = ((Datum - lngT - 3 + (Weekday(lngT) + 1) Mod 7)) \ 7 + 1
If .Range(.Cells(Zeile_1_Q, 3), .Cells(Zeile_Q, 3)).Value = DINKw(Date) Or _
.Range(.Cells(Zeile_1_Q, 3), .Cells(Zeile_Q, 3)).Value = "" Then
'Status-Werte kopieren
Set rngCopy = .Range(.Cells(Zeile_1_Q, 4), .Cells(Zeile_Q, 4))
rngCopy.Copy
wksZiel.Cells(Zeile_Z, 3).PasteSpecial Paste:=xlPasteValues
'Aufgaben kopieren
Set rngCopy = .Range(.Cells(Zeile_1_Q, 2), .Cells(Zeile_Q, 2))
rngCopy.Copy
wksZiel.Cells(Zeile_Z, 4).PasteSpecial Paste:=xlPasteValues
'Wochentags-Daten kopieren
Set rngCopy = .Range(.Cells(Zeile_1_Q, 5), .Cells(Zeile_Q, 9))
rngCopy.Copy
wksZiel.Cells(Zeile_Z, 10).PasteSpecial Paste:=xlPasteValues
End If
End With
'Zellbereich für den eingefügten Namen formatieren
With wksZiel
With .Range(.Rows(Zeile_Z), .Rows(Zeile_Z + AnzahlZeilen - 1))
.Interior.ColorIndex = xlColorIndexNone
.Font.Bold = False
End With
'Rahmen Spalte B:C
With .Range(.Cells(Zeile_Z, 2), .Cells(Zeile_Z + AnzahlZeilen - 1, 3))
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlLineStyleNone
End With
End With
'Rahmen Spalte D:I
With .Range(.Cells(Zeile_Z, 4), .Cells(Zeile_Z + AnzahlZeilen - 1, 9))
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With .Borders(xlInsideVertical)
.LineStyle = xlLineStyleNone
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlLineStyleNone
End With
End With
'Rahmen Spalte J:N
With .Range(.Cells(Zeile_Z, 10), .Cells(Zeile_Z + AnzahlZeilen - 1, 14))
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlLineStyleNone
End With
For Each rngCopy In .Cells
If IsNumeric(rngCopy.Text) Then rngCopy.Value = "x"
Next
End With
'Zellen in Spalte B verbinden
With .Range(.Cells(Zeile_Z, 2), .Cells(Zeile_Z + AnzahlZeilen - 1, 2))
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
'Hyperlink auf Blatt einfügen
.Hyperlinks.Add Anchor:=.Cells(Zeile_Z, 2), Address:="", _
SubAddress:="'" & wksQuelle.Name & "'!A1", _
TextToDisplay:=wksQuelle.Name, _
ScreenTip:="Tabelle " & wksQuelle.Name
End With
Zeile_Z = Zeile_Z + AnzahlZeilen
End If
Next wksQuelle
'Makrobremsen lösen
With Application
.ScreenUpdating = True
.Calculation = StatusCalc
.Calculate
End With
End Sub
für Fett markierten Bereich benötige ich jetzt eine neue Prüfzeile.
Mein schon eingearbeiteter Vorschlag funktioniert nicht.
Es sollen nur die Aufgaben mit Status und Arbeitszeit übertragen werden, wenn in Spalte C der Mitarbeiterblätter die aktuelle KW steht und wenn in in Spalte D NICHT fix steht (d.h. fix aufgaben sollen auch nicht übertragen werden)
Im bsp. wird dies klarer.
Das Makro ist im Dashboard im Button "Aufgaben in Dashboard integrieren".
https://www.herber.de/bbs/user/109430.xlsm
Vielen Dank.
Berndt

7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Prüfzeile einbinden
15.11.2016 14:06:51
Max2

With wksQuelle
lngT = DateSerial(Year(Datum + (8 - Weekday(Datum)) Mod 7 - 3), 1, 1)
DINKw = ((Datum - lngT - 3 + (Weekday(lngT) + 1) Mod 7)) \ 7 + 1
Was ist "Datum" ?
Konnte ich nicht im Code finden und hat auch keinen Wert.
AW: Prüfzeile einbinden
15.11.2016 14:24:42
Berndt
Hey Basti.
Kann die Datei nicht öffnen. Fehler
Kannst du erneut die Datei reinstellen, damit ich testen kann?
VG Berndt
Anzeige
AW: Prüfzeile einbinden
15.11.2016 14:29:04
baschti007
Hm bei mir geht es nun ja dann der Code
Hier.
Gruß Basti
Sub Aufgabenübertragung()
Dim wksZiel As Worksheet
Dim wksQuelle As Worksheet
Dim Zeile_1_Z&, Zeile_1_Q&, Zeile_Z&, Zeile_Q&, AnzahlZeilen&
Dim rngCopy As Range
Dim StatusCalc As Long
Dim Lastaf2 As Long
Dim lngT As Long
Dim rngarr()
Dim x&, r&, c&
Set wksZiel = Worksheets("Dashboard")
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' _
'Makrobremsen lösen
With Application
.ScreenUpdating = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
End With
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' _
'Altdaten in Zieltabelle löschen
With wksZiel
Zeile_1_Z = .Range("Zelle_Name").Row + 1
If .Cells(Zeile_1_Z, 4) = "" Then
'keine Daten unter Titelzeile in SPalte D eingetragen-->keine Altdaten vorhanden
Else
'Letzte Zeile mit Aufgabe
Zeile_Z = .Cells(Zeile_1_Z - 1, 4).End(xlDown).Row
'Zeilen löschen
.Range(.Rows(Zeile_1_Z), .Rows(Zeile_Z)).Delete Shift:=xlShiftUp
End If
Zeile_Z = Zeile_1_Z
End With
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' _
'Tabellen abarbeiten
For Each wksQuelle In ActiveWorkbook.Worksheets
'Anfang des Blattnamens prüfen
If (UCase(wksQuelle.Name) Like "*HERR*" Or UCase(wksQuelle.Name) Like "*FRAU*") Then
With wksQuelle
Zeile_1_Q = 8
If .Cells(Zeile_1_Q, 2).Text  "" Then
'Zeile mit letzter Aufgabe in Spalte B
Zeile_Q = .Cells(Zeile_1_Q - 1, 2).End(xlDown).Row
Else
'keine Aufgabe vorhanden
Zeile_Q = Zeile_1_Q
End If
AnzahlZeilen = Zeile_Q - Zeile_1_Q + 1
End With
' daten in array einlesen
With wksQuelle
lngT = DateSerial(Year(Date + (8 - Weekday(Date)) Mod 7 - 3), 1, 1)
DINKw = ((Date - lngT - 3 + (Weekday(lngT) + 1) Mod 7)) \ 7 + 1
rngarr = .Range(.Cells(Zeile_1_Q - 1, 2), .Cells(Zeile_Q, 9)).Value
End With
'daten von array in Dashboard einfügen
x = Zeile_Z
With wksZiel
For r = LBound(rngarr, 1) To UBound(rngarr, 1)
If Replace(rngarr(r, 2), "KW ", "") = DINKw And rngarr(r, 3)  "fix" Then
.Cells(Zeile_Z, 2) = wksQuelle.Name
.Rows(x + 1).Insert
.Cells(x, 3) = rngarr(r, 3)
.Cells(x, 4) = rngarr(r, 1)
For c = UBound(rngarr, 2) - 4 To UBound(rngarr, 2)
.Cells(x, c + 6) = rngarr(r, c)
Next
x = x + 1
End If
Next
End With
If x  Zeile_Z Then
'Zellbereich für den eingefügten Namen formatieren
With wksZiel
With .Range(.Rows(Zeile_Z), .Rows(x - 1))
.Interior.ColorIndex = xlColorIndexNone
.Font.Bold = False
End With
'Rahmen Spalte B:C
With .Range(.Cells(Zeile_Z, 2), .Cells(x - 1, 3))
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlLineStyleNone
End With
End With
'Rahmen Spalte D:I
With .Range(.Cells(Zeile_Z, 4), .Cells(x - 1, 9))
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With .Borders(xlInsideVertical)
.LineStyle = xlLineStyleNone
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlLineStyleNone
End With
End With
'Rahmen Spalte J:N
With .Range(.Cells(Zeile_Z, 10), .Cells(x - 1, 14))
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlLineStyleNone
End With
'For Each rngCopy In .Cells
'   If IsNumeric(rngCopy.Text) Then rngCopy.Value = "x"
'Next
End With
'Zellen in Spalte B verbinden
With .Range(.Cells(Zeile_Z, 2), .Cells(x - 1, 2))
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
'Hyperlink auf Blatt einfügen
.Hyperlinks.Add Anchor:=.Cells(Zeile_Z, 2), Address:="", _
SubAddress:="'" & wksQuelle.Name & "'!A1", _
TextToDisplay:=wksQuelle.Name, _
ScreenTip:="Tabelle " & wksQuelle.Name
End With
Zeile_Z = x
End If
End If
Next wksQuelle
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' _
'Makrobremsen lösen
With Application
.ScreenUpdating = True
.Calculation = StatusCalc
.Calculate
End With
End Sub
Wird aber nicht kopiert sondern in eine Array geladen.
Anzeige
Danke
15.11.2016 15:02:26
Berndt
Ganz große Klasse.
Funktioniert richtig toll.
Es braucht zwar eine gewisse Zeit um die Sheets durchzuprüfen. Aber das Ergebnis ist richtig Mega.
Sorry
15.11.2016 14:22:39
Berndt
entschuldigung.
Dim lngT As Date
Dim Datum As Date
AW: Sorry
15.11.2016 14:32:10
Max2
Ich gehe mal davon aus dass es jetzt geht oder ?
Soweit ich das einschätzen kann lag es nur daran das Datum noch nicht definiert/deklariert war.

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige