Farbige Zellen suchen und Zuordnung auflisten

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub NeuSortieren() Dim bytI As Byte, bytLastC As Byte Dim lngI As Long, lngLastRow As Long Dim wksQuelle As Worksheet, wksZiel As Worksheet ' Hier kannst du dann den Datei und Tabellen Namen anpassen !!! Set wksQuelle = Workbooks("Abteilung.xls").Worksheets("2008") With ThisWorkbook bytLastC = wksQuelle.Cells(1, 255).End(xlToLeft).Column lngLastRow = wksQuelle.Cells(65535, 1).End(xlUp).Row Set wksZiel = .Worksheets.Add wksZiel.Name = "Abteilung" For bytI = 2 To bytLastC wksZiel.Cells(1, bytI) = wksQuelle.Cells(1, bytI) wksZiel.Cells(1, bytI).Font.Bold = True For lngI = 2 To lngLastRow If wksQuelle.Cells(lngI, bytI).Interior.ColorIndex xlNone Then wksZiel.Cells(2, bytI) = wksQuelle.Cells(lngI, 1) Exit For End If Next lngI Next bytI End With wksZiel.Cells(1, 1) = "Kalenderwoche" wksZiel.Cells(2, 1) = "Mitarbeiter" End Sub

Hallo Heike,
dann so mit ein wenig manuellen Input:
Bitte bei der Abfrage der Trennzeile die Zeile im Tabellenblatt mit der Maus markieren die die Trennlinie zwischen den beiden Abteilungen darstellt. Diese Abfrage läßt sich bestimmt noch automatisieren, aber nur dann wenn man weiß ob es immer eine Leerzeile oder doch zwei oder gar keine zwischen den Abteilungen gibt. Will sagen man muß mehr Rahmenbedingungen kennen um alles zu berücksichtigen.


Sub NeuSortieren2()
Dim bytI As Byte, bytLastC As Byte
Dim lngI As Long, lngLastRow As Long, lngTrennZeile As Long
Dim wksQuelle As Worksheet, wksZiel As Worksheet
Dim rngTrennZeile As Range
' Hier kannst du dann den Datei und Tabellen Namen anpassen !!!
Set wksQuelle = Workbooks("Abteilung.xls").Worksheets("2008")
bytLastC = wksQuelle.Cells(1, 255).End(xlToLeft).Column
lngLastRow = wksQuelle.Cells(65535, 1).End(xlUp).Row
Workbooks("Abteilung.xls").Activate
Set rngTrennZeile = Application.InputBox("Markieren Sie bitte die 'Trennzeile' zwischen den  _
Abteilungen", " Trennzeile", Type:=8)
lngTrennZeile = rngTrennZeile.Row
Set wksZiel = ThisWorkbook.Worksheets.Add
wksZiel.Name = "Abteilung"
For bytI = 2 To bytLastC
wksZiel.Cells(1, bytI) = wksQuelle.Cells(1, bytI)
wksZiel.Cells(1, bytI).Font.Bold = True
wksZiel.Cells(3, bytI) = wksQuelle.Cells(1, bytI)
wksZiel.Cells(3, bytI).Font.Bold = True
For lngI = 2 To lngLastRow
If wksQuelle.Cells(lngI, bytI).Interior.ColorIndex  xlNone Then
If wksQuelle.Cells(lngI, bytI).Row > lngTrennZeile Then
wksZiel.Cells(4, bytI) = wksQuelle.Cells(lngI, 1)
Else
wksZiel.Cells(2, bytI) = wksQuelle.Cells(lngI, 1)
End If
End If
Next lngI
Next bytI
wksZiel.Cells(1, 1) = "Kalenderwoche Abteilung 1"
wksZiel.Cells(2, 1) = "Mitarbeiter"
wksZiel.Cells(3, 1) = "Kalenderwoche Abteilung 2"
wksZiel.Cells(4, 1) = "Mitarbeiter"
End Sub

Gruß Heiko
PS: Rückmeldung wäre nett !

schönen guten morgen...
und natürlich auch erst mal nen lieben dank.
im prinzip würde die formatierung immer so aussehen, wie ich sie als letzes hoch geladen habe (eine leerzeile, dann die abteilungsbezeichnung, was wohl auch als leerzeile zu werten ist und dann beginnt die aufzählung der mitarbeiter).
ich vermute mal, dass denmächst weitere abteilungen unten angehängt werden, daher mal ne blöde frage: kann man das nicht vielleicht so abfragen, dass einfach: von oben nach unten (zum beipiel zeile 120 als grenze) alle farbigen zellen der spalte erfasst und dann die "gematchten" mitarbeiter in der soll-tabelle untereinander, zugeordnet zur kw, auflistet? Die Reihenfolge der Abteilungen in der ist-tabelle würde gleich bleiben (soviel ist sicher)...so könnte man doch dies in der bestehenden soll-tabelle schon vorgeben und setzt dann die treffer nur dahinter.
sorry, ist wohl etwas konfus geworden...und scheinbar habe ich bei den automatisierungsmöglichkeiten blut gelegt und die bodenhaftung verloren.
ich mache noch mal ne datei zur verdeutlichung.
https://www.herber.de/bbs/user/54466.xls
vielen dank und lieben gruß
Heike

Option Explicit Sub NeuSortieren2() Dim lngC As Long, lngSp As Long, lngR As Long, lngZe As Long Dim lngAbt As Long, arrE() As String, lngE As Long With Worksheets("Ist-Zustand") lngZe = .Cells(.Rows.Count, 1).End(xlUp).Row lngSp = .Cells(1, .Columns.Count).End(xlToLeft).Column lngAbt = WorksheetFunction.CountBlank(Range(Cells(1, 1), Cells(lngZe, 1))) + 2 ReDim arrE(1 To lngAbt, 1 To lngSp) arrE(1, 1) = "Kalenderwoche" arrE(2, 1) = .Cells(1, 1) lngE = 2 For lngC = 2 To lngSp arrE(1, lngC) = .Cells(1, lngC) Next lngC For lngR = 2 To lngZe For lngC = 2 To lngSp If IsEmpty(.Cells(lngR, 1)) Then lngE = lngE + 1 arrE(lngE, 1) = .Cells(lngR + 1, 1) lngR = lngR + 2 End If If .Cells(lngR, lngC).Interior.ColorIndex xlNone Then _ arrE(lngE, lngC) = .Cells(lngR, 1) Next lngC Next lngR End With Worksheets.Add.Name = "Soll-Zustand1" Range(Cells(1, 1), Cells(lngAbt, lngSp)) = arrE Rows(1).Font.Bold = True Cells.HorizontalAlignment = xlCenter Columns(1).AutoFit End Sub

Sub transponieren() Dim inSpalte As Integer Dim inZeile As Integer Dim wsTabelle1 As Worksheet Set wsTabelle1 = Worksheets("Ist-Zustand") With Worksheets("Soll-Zustand") For inSpalte = 2 To IIf(IsEmpty(.Cells(1, .Columns.Count)), .Cells(1, .Columns.Count). _ End(xlToLeft).Column, .Columns.Count) For inZeile = 2 To IIf(IsEmpty(.Cells(1, .Columns.Count)), .Cells(1, .Columns.Count) _ .End(xlToLeft).Column, .Columns.Count) If wsTabelle1.Cells(inZeile, inSpalte).Interior.ColorIndex = 10 Then .Cells(2, inSpalte) = wsTabelle1.Cells(inZeile, 1) Exit For End If Next inZeile Next inSpalte End With End Sub

Beliebteste Forumthreads (12 Monate)

Farbige Zellen suchen und Zuordnung auflisten

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

311 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Farbige Zellen suchen und Zuordnung auflisten

15 Beiträge zum Forumthread Beiträge zu diesem Forumthread

311 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread