Arcor Einzelverbindungsnachweis mit Excel formatieren
Mit Hilfe der Einzelverbindungsnachweise lassen sich die verbrauchten Einheiten je Rufnummer ermitteln.
Diese lassen sich für die letzten 3 Monate aus dem Kundencenter als CSV-Dateien herunterladen und z. B. mit Excel® öffnen.
Allerdings sieht das Ganze wenig hilfreich und alles andere als übersichtlich aus:
Um nicht jedesmal das Layout so anpassen zu müssen, damit man etwas damit anfangen kann, wurde ein Makro für Excel® geschrieben. Nach dem Anwenden des Makros (Alt+F8) sieht die Tabelle dann wie folgt aus:
Zur Verwendung dieses Beispiels beachten Sie bitte die wichtigen Hinweise, die auch für Excel® gelten. Den Code kopieren Sie am Besten in die Persönliche Arbeitsmappe, damit er immer zur Verfügung steht.
Für Excel® 2003, Excel® 2007
Option Explicit '------------------------------------------------------------------------- ' Spalte "Anbieter" wird mit "False" aus- und mit "True" eingeblendet '------------------------------------------------------------------------- Private Const SHOWPROVIDER As Boolean = False Public Sub Einzelverbindungsnachweis() '===================================================================== ' Formatiert Einzelverbindungsnachweise von Arcor, fügt Teilergebnisse ' ein und speichert sie als xls-Datei ab '--------------------------------------------------------------------- ' (c) EDV-Service Marchert - Alle Rechte vorbehalten ' Autor: Peter Marchert ' Weitergabe und Veröffentlichung nur nach vorheriger Zustimmung durch ' den Autor gestattet '--------------------------------------------------------------------- ' 2009-01-21 - Version 1.0.0 ' 2009-01-22 - Version 1.1.0 '===================================================================== Dim strFileName As String On Error Resume Next '--------------------------------------------------------------------- ' Ist die aktuelle Datei kein Einzeverbindungsnachweis? '--------------------------------------------------------------------- If LCase(Right(ActiveWorkbook.Name, 4)) <> ".csv" Or Range("A1").Value <> "Anschluss" Then MsgBox "Diese Tabelle scheint kein Einzelverbindungsnachweis zu sein." _ , vbCritical + vbOKOnly, "Einzelverbindungsnachweis formatieren" Exit Sub End If '--------------------------------------------------------------------- ' Alles markieren '--------------------------------------------------------------------- Cells.Select '--------------------------------------------------------------------- ' Schriftart "Arial 9" einstellen '--------------------------------------------------------------------- Cells.Font.Name = "Arial": Cells.Font.Size = 9 '--------------------------------------------------------------------- ' Autofilter einschalten '--------------------------------------------------------------------- Selection.AutoFilter '--------------------------------------------------------------------- ' 1. Zeile fixieren '--------------------------------------------------------------------- ActiveWindow.SplitRow = 1: ActiveWindow.FreezePanes = True '--------------------------------------------------------------------- ' Jede 2. Zelle farbig unterlegen (bedingte Formatierung) '--------------------------------------------------------------------- With ActiveSheet.UsedRange .FormatConditions.Add Type:=xlExpression, Formula1:="=REST(ZEILE();2)=1" .FormatConditions(1).Interior.ColorIndex = 19 End With '--------------------------------------------------------------------- ' Betragsspalte mit € formatieren '--------------------------------------------------------------------- Columns("M:M").NumberFormat = "#,##0.0000 €" '--------------------------------------------------------------------- ' Teilergebnisse einfügen '--------------------------------------------------------------------- Range("A2").Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(13), _ Replace:=True, PageBreaks:=False, SummaryBelowData:=True '--------------------------------------------------------------------- ' Rahmen einfügen '--------------------------------------------------------------------- With ActiveSheet.UsedRange.Borders(xlEdgeLeft) .LineStyle = xlDash .Weight = xlThin End With With ActiveSheet.UsedRange.Borders(xlEdgeTop) .LineStyle = xlDash .Weight = xlThin End With With ActiveSheet.UsedRange.Borders(xlEdgeBottom) .LineStyle = xlDash .Weight = xlThin End With With ActiveSheet.UsedRange.Borders(xlEdgeRight) .LineStyle = xlDash .Weight = xlThin End With With ActiveSheet.UsedRange.Borders(xlInsideVertical) .LineStyle = xlDash .Weight = xlThin End With With ActiveSheet.UsedRange.Borders(xlInsideHorizontal) .LineStyle = xlDash .Weight = xlThin End With '--------------------------------------------------------------------- ' Summen 2-stellig und fett formatieren '--------------------------------------------------------------------- Call FormatSums '--------------------------------------------------------------------- ' Automatische Spaltenbreiten einstellen '--------------------------------------------------------------------- Selection.Columns.AutoFit '--------------------------------------------------------------------- ' Überschriftenzeile hervorheben '--------------------------------------------------------------------- With Range("A1:N1") .FormatConditions.Delete .Interior.ColorIndex = 16 .Font.Bold = True .Font.ColorIndex = 2 End With '--------------------------------------------------------------------- ' Zum Drucken aufbereiten '--------------------------------------------------------------------- Call PageSetup '--------------------------------------------------------------------- ' 1. Zelle im Datenbereich markieren '--------------------------------------------------------------------- Range("A2").Select '--------------------------------------------------------------------- ' Dateinamen generieren '--------------------------------------------------------------------- strFileName = Replace(ActiveSheet.Name, "EVN_", "") strFileName = Left(strFileName, 4) & "-" & Right(strFileName, 2) & _ " - Acror Einzelverbindungsnachweis" '--------------------------------------------------------------------- ' Als Excel-Datei speichern '--------------------------------------------------------------------- Call ActiveWorkbook.SaveAs(Filename:=ActiveWorkbook.Path & "\" & _ strFileName, AccessMode:=xlShared, FileFormat:=xlNormal) '--------------------------------------------------------------------- ' Verhindern, dass Excel den Anwender mit einer Speicherabfrage beim ' Schließen nervt '--------------------------------------------------------------------- ActiveWorkbook.Saved = True End Sub Private Sub FormatSums() '===================================================================== ' Sucht nach "ergebnis" in der Spalte "A" und formatiert dann die Zeile, ' sowie die Summe in Spalte "M". '===================================================================== Dim objCell As Object Dim strAddress As String With ActiveSheet.Range("A:A") '----------------------------------------------------------------- ' Enthält die Zelle den Begriff "ergebnis"? '----------------------------------------------------------------- Set objCell = .Find("ergebnis", LookIn:=xlValues, LookAt:=xlPart) '----------------------------------------------------------------- ' Wenn ja, dann... '----------------------------------------------------------------- If Not objCell Is Nothing Then '------------------------------------------------------------- ' Adresse merken, um Endlosschleife zu verhindern '------------------------------------------------------------- strAddress = objCell.Address '------------------------------------------------------------- ' Schleife durchlaufen, solange... '------------------------------------------------------------- Do '--------------------------------------------------------- ' Summe formatieren '--------------------------------------------------------- Call FormatSum(objCell) '--------------------------------------------------------- ' Gesamtergebnis zusätzlich mit Rahmen schmücken '--------------------------------------------------------- If objCell.Value = "Gesamtergebnis" Then With Cells(objCell.Row, 13) .Borders(xlEdgeRight).Weight = xlMedium .Borders(xlEdgeLeft).Weight = xlMedium .Borders(xlEdgeTop).Weight = xlMedium .Borders(xlEdgeTop).LineStyle = xlContinuous .Borders(xlEdgeBottom).Weight = xlMedium .Borders(xlEdgeBottom).LineStyle = xlContinuous End With End If '--------------------------------------------------------- ' Nächste Zelle mit "ergebnis" suchen '--------------------------------------------------------- Set objCell = .FindNext(objCell) '------------------------------------------------------------- ' ...weitere Zellen mit "ergebnis" gefunden werden und die ' Zelladresse <> der 1. Fundstelle ist '------------------------------------------------------------- Loop While Not objCell Is Nothing And objCell.Address <> strAddress End If End With '--------------------------------------------------------------------- ' Clean Up '--------------------------------------------------------------------- Set objCell = Nothing End Sub Private Sub FormatSum(ByVal objRange As Object) '--------------------------------------------------------------------- ' 2-stellig Euro '--------------------------------------------------------------------- Cells(objRange.Row, 13).NumberFormat = "#,##0.00 $" '--------------------------------------------------------------------- ' Fett '--------------------------------------------------------------------- Cells(objRange.Row, 13).Font.Bold = True '--------------------------------------------------------------------- ' Zeile vom Rest der Tabelle abheben '--------------------------------------------------------------------- With Range("A" & objRange.Row & ":N" & objRange.Row) .FormatConditions.Delete .Interior.ColorIndex = 15 .RowHeight = 18 .VerticalAlignment = xlCenter .Borders(xlInsideVertical).LineStyle = xlNone .Borders(xlInsideHorizontal).LineStyle = xlNone End With '--------------------------------------------------------------------- ' Clean Up '--------------------------------------------------------------------- Set objRange = Nothing End Sub Private Sub PageSetup() '--------------------------------------------------------------------- ' Wird die Spalte "Anbieter" angezeigt, werden andere Spalten ver- ' kleinert, um einen besseren Ausdruck zu erhalten. '--------------------------------------------------------------------- If SHOWPROVIDER Then Columns("A:A").ColumnWidth = 14 Columns("F:F").ColumnWidth = 11 Columns("J:J").ColumnWidth = 10 Columns("H:H").ColumnWidth = 14 Else Columns("N:N").EntireColumn.Hidden = True End If '--------------------------------------------------------------------- ' Die Spalten mit den abgekürzten Tarif- und Zeitzonen werden ausgeblendet '--------------------------------------------------------------------- Columns("G:G").EntireColumn.Hidden = True Columns("I:I").EntireColumn.Hidden = True With ActiveSheet.PageSetup '----------------------------------------------------------------- ' Querformat festlegen '----------------------------------------------------------------- .Orientation = xlLandscape '----------------------------------------------------------------- ' Vertikal zentrieren '----------------------------------------------------------------- .CenterHorizontally = True '----------------------------------------------------------------- ' Tabellenbreite auf 1 Seite erzwingen '----------------------------------------------------------------- .FitToPagesWide = 1: .FitToPagesTall = 40: .Zoom = False '----------------------------------------------------------------- ' Kopfzeile festlegen '----------------------------------------------------------------- .CenterHeader = "Arcor - Einzelverbindungsnachweis" '----------------------------------------------------------------- ' Fusszeile festlegen '----------------------------------------------------------------- .LeftFooter = "&F" .CenterFooter = "Seite &P von &N" .RightFooter = "Druckdatum: &D &T" '----------------------------------------------------------------- ' 1. Zeile als Wiederholungszeile festlegen '----------------------------------------------------------------- .PrintTitleRows = "$1:$1" '----------------------------------------------------------------- ' Seitenränder festlegen (in cm) '----------------------------------------------------------------- .LeftMargin = Application.CentimetersToPoints(0.5) .RightMargin = Application.CentimetersToPoints(0.5) .TopMargin = Application.CentimetersToPoints(2.5) .HeaderMargin = Application.CentimetersToPoints(1.8) .BottomMargin = Application.CentimetersToPoints(1.5) .FooterMargin = Application.CentimetersToPoints(0.7) '----------------------------------------------------------------- ' Seitenansicht anzeigen? '----------------------------------------------------------------- If MsgBox("Seitenansicht anzeigen?", vbQuestion + vbYesNo + vbDefaultButton2 _ , "Einzelverbindungsnachweis formatieren") = vbYes Then ActiveWindow.SelectedSheets.PrintPreview End If End With End Sub