AW: Einträge neu gliedern
22.01.2016 15:17:11
fcs
Hallo BlueBird,
die vielen Formatierung (z.B. niedrige Zwischenzeilen mit Rahmen) machten die Programmierung sehr mühsehlig.
Gruß
Franz
Sub Daten_neu_gliedern()
Dim wks_Q As Worksheet
Dim wks_Z As Worksheet
Dim Zeile_Q As Long, Zeile_QL As Long
Dim Zeile_Z As Long, Zeile_ZL As Long, Spalte_Z As Long, Spalte_ZL As Long
Dim varName, Zelle As Range
Dim strPlan$, varIndex, varLS, datDatum As Date
Set wks_Q = Worksheets(2) 'Worksheets("Tabelle2") Quelltabelle
Set wks_Z = Worksheets(1) 'Worksheets("Tabelle1") Zieltabelle
Const HoeheZei_1 = 35
Const HoeheZei_2 = 5
Const BreiteSpa_name = 12.57
Const Breite_AB = 10.71
Application.ScreenUpdating = False
'Basis-Formatierung einstellen
With ActiveWorkbook
With .Styles("Standard")
.Font.Name = "Calibri"
.Font.Size = 11
End With
End With
'Spalten und Zeilen im Zielblatt formatieren
With wks_Z
With .Cells
.Clear 'Alles löschen
.Style = "Standard"
.Rows.AutoFit
.VerticalAlignment = xlCenter
End With
With .Columns
.HorizontalAlignment = xlCenter
.ColumnWidth = BreiteSpa_name
End With
.Columns(1).ColumnWidth = Breite_AB
.Columns(1).HorizontalAlignment = xlLeft
.Columns(2).ColumnWidth = Breite_AB
.Rows.RowHeight = HoeheZei_1
.Rows(1).RowHeight = 75.75
.Rows(1).Orientation = 90
End With
'Alle Namen übertragen nach Zeile 1
With wks_Q
Zeile_QL = .Cells(.Rows.Count, 1).End(xlUp).Row
For Zeile_Q = 2 To Zeile_QL
varName = .Cells(Zeile_Q, 1).Text
With wks_Z
Set Zelle = .Rows(1).Find(what:=varName, LookIn:=xlValues, lookat:=xlWhole)
If Zelle Is Nothing Then
Spalte_Z = .Cells(1, .Columns.Count).End(xlToLeft).Column
If Spalte_Z > 2 Then
Spalte_Z = Spalte_Z + 1
Else
Spalte_Z = 3
End If
.Cells(1, Spalte_Z).Value = varName
End If
End With
Next
End With
'Rahmen in Zeile 1 formatieren
With wks_Z
Spalte_ZL = .Cells(1, .Columns.Count).End(xlToLeft).Column
With .Range(.Cells(1, 1), .Cells(1, Spalte_ZL))
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
End With
End With
'Höhe Zeile 2
Zeile_Z = 2
wks_Z.Rows(Zeile_Z).RowHeight = HoeheZei_2
'Liste in Quelltabelle abarbeiten
With wks_Z
For Zeile_Q = 2 To Zeile_QL
'Werte in Zeile einlesen
varName = wks_Q.Cells(Zeile_Q, 1)
varIndex = wks_Q.Cells(Zeile_Q, 3)
varLS = wks_Q.Cells(Zeile_Q, 4)
datDatum = wks_Q.Cells(Zeile_Q, 5)
'Prüfen, ob sich die Plan-Nr geändert hat
If strPlan wks_Q.Cells(Zeile_Q, 2).Text Then
'neue Plan-Nr. merken
strPlan = wks_Q.Cells(Zeile_Q, 2).Text
If Zeile_Z > 2 Then
'Höhe von 2 Zeilen reduzieren und Rahmen zwischen Zeilen formatieren
Zeile_Z = Zeile_Z + 1
.Rows(Zeile_Z).RowHeight = HoeheZei_2
Zeile_Z = Zeile_Z + 1
.Rows(Zeile_Z).RowHeight = HoeheZei_2
With .Range(.Cells(Zeile_Z - 1, 1), .Cells(Zeile_Z, Spalte_ZL))
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
End With
End If
'Zeilennummer erhöhen und Plan-nr. eintragen
Zeile_Z = Zeile_Z + 1
.Cells(Zeile_Z, 1) = strPlan
Else
'Zeilennummer erhöhen und Rahmen zwischen Idexen formatieren
Zeile_Z = Zeile_Z + 1
With .Range(.Cells(Zeile_Z - 1, 2), .Cells(Zeile_Z, Spalte_ZL))
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
End With
End If
'Index eintragen
.Cells(Zeile_Z, 2) = varIndex
'Spalte mit Name in Zeile 1 suchen
Set Zelle = .Rows(1).Find(what:=varName, LookIn:=xlValues, lookat:=xlWhole)
Spalte_Z = Zelle.Column
'Lieferschein und Datum in Spalte eintragen
.Cells(Zeile_Z, Spalte_Z).Value = varLS & Chr(10) & Format(datDatum, "DD.MM.YYYY")
Next
'Zeilennummer erhöhen, Höhe reduzieren und dicken rahmen um alle Daten
Zeile_ZL = Zeile_Z + 1
.Rows(Zeile_ZL).RowHeight = HoeheZei_2
With .Range(.Cells(1, 1), .Cells(Zeile_ZL, Spalte_ZL))
.BorderAround LineStyle:=xlContinuous, Weight:=xlThick
End With
'Zellen A1:B1 verbinden
.Range(.Cells(1, 1), .Cells(1, 2)).Merge
End With
Application.ScreenUpdating = True
End Sub