AW: Excel Datei nach Farben splitten
02.11.2020 18:06:12
Yal
Hallo MCeeel,
Lustig! Mal was ganz anderes.
Ich war ein Bischen faul und habe in den ZielTabelle nur der Inhalt der Spalte 1 gespeichert. Der Rest ist eh als Dateiname zu haben.
(Durchlesen, verstehen, Zielverzeichnis anpassen. Oder herstellen)
Const cFCode = "255;65535;15773696"
Const cFName = "Rot;Gelb;Blau"
Private C As Collection
Private WS1 As Worksheet
Public Sub Durchlaufen()
Dim i As Integer, E
Dim strKey As String
Set C = New Collection
Set WS1 = ThisWorkbook.Worksheets(1)
'Farbe und Zahl "sammeln"
For i = 2 To WS1.Range("A1").End(xlDown).Row
strKey = Farbe_decodieren(WS1.Cells(i, 3).Interior.Color) & WS1.Cells(i, 2)
CollAdd strKey
Next i
'Was Steht in der Sammlung
'For Each E In C: Debug.Print E: Next
'Eine Tabelle pro gesammelte Element
Tabellen_herstellen
'Kopieren in die richtige Tabelle
For i = 2 To WS1.Range("A1").End(xlDown).Row
strKey = Farbe_decodieren(WS1.Cells(i, 3).Interior.Color) & WS1.Cells(i, 2)
Worksheets(strKey).Range("A10000").End(xlUp).Offset(1, 0) = WS1.Cells(i, 1)
Next
'Tabellen als einzelne Datei speichern
FarbTabelle_speichern
End Sub
Private Sub Tabellen_herstellen()
Dim WS As Worksheet
Dim E
For Each E In C
Set WS = ThisWorkbook.Worksheets.Add
WS.Name = E
WS.Range("A1") = WS1.Range("A1")
Next
End Sub
Private Function Farbe_decodieren(FCode As Long) As String
Dim i
Dim arrFarbe
Farbe_decodieren = "" 'Default-Value
arrFarbe = Split(cFCode, ";")
For i = 0 To UBound(arrFarbe)
If FCode = arrFarbe(i) Then
Farbe_decodieren = Split(cFName, ";")(i)
Exit For 'steigt schneller aus
End If
Next
End Function
Private Sub CollAdd(Elt As String)
On Error Resume Next
C.Add Elt, Elt
End Sub
Private Sub FarbTabelle_speichern()
Dim WS As Worksheet
Dim DName As String
For Each WS In Worksheets
If WS.Name WS1.Name Then
DName = "C:\temp\" & WS.Name & ".xlsx"
WS.Move
ActiveWorkbook.SaveAs Filename:=DName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:= _
False
ActiveWorkbook.Close
End If
Next
End Sub
Viel Erfolg
Yal