AW: An Franz: Bitte um Hilfe - Makro läuft nicht mehr
27.01.2011 23:08:09
heidi
Hallo Reinhard,
habe das erste Problem lösen können. Es lag daran, dass ich die Tabelle in einen Bereich konvertieren musste - warum auch immer.
Doch jetzt kommt gleich das Nächste:
Fehlermeldung: Überlauf - Makro erstellt 6 Dateien für Regionalcentren, bleibt dann stehen bei
'Alle Daten anzeigen, ggf. Autofilter aktivieren
With wksRohdaten
If .AutoFilterMode = True Then
If .Cells.SpecialCells(xlCellTypeVisible).Count
Hier der vollständige Code:
'27.01.2011: Angepasster Programmcode für VKG-Analyse vereinzeln; H.Fischer
Option Explicit
Private wbRohdaten As Workbook, wksRohdaten As Worksheet
Private sPfad As String, sFormel As String
Private wbAusgang As Workbook
Private wbAnalyse As Workbook, wksAnalyse As Worksheet
Private StatusTxt As String
Sub Vereinzeln()
Dim sEingabe As String
sEingabe = InputBox(Prompt:="Für welches Jahr und welchen Monat (JJJJ-MM) möchten Sie die Verkaufsgebietsanalysen erstellen?", _
Title:="Verkaufsgebietsanlysen erstellen - Jahr und Monat", Default:=Format(Date - 20, "YYYY-MM"))
If sEingabe = "" Then GoTo Beenden
Set wbRohdaten = ActiveWorkbook
Set wksRohdaten = wbRohdaten.Worksheets(1) 'Tabelle mit den Rohdaten
'Verzeichnis der Dateien
sPfad = wbRohdaten.Path & Application.PathSeparator
'Datei mit den Ausgangsdaten (Blätter MA,BPL, Landkreis, VKG 2010, Legende) _
schreibgeschützt öffnen
Set wbAusgang = Workbooks.Open(Filename:=sPfad & "Test_Ausgangsdatei.xls", ReadOnly:=True)
wbRohdaten.Activate
Application.ScreenUpdating = False
'Autofilter in den Rohdaten einrichten
With wksRohdaten
.Activate
If .AutoFilterMode = True Then
If .Cells.SpecialCells(xlCellTypeVisible).Count
.ShowAllData
End If
Else
.UsedRange.AutoFilter
End If
End With
'Kundenanalyse je Regionalcentrum
StatusTxt = "Dateien für die Regionalzentren werden erstellt"
If KundenanalyseRC(lSpalte:=2, DocTitelText:="Regionalzentrum: ", _
Dateiname1:="VKG-Analyse_", sYYYY_MM:=sEingabe) = False Then GoTo Beenden
'Alle Daten anzeigen, ggf. Autofilter aktivieren
With wksRohdaten
If .AutoFilterMode = True Then
If .Cells.SpecialCells(xlCellTypeVisible).Count
.ShowAllData
End If
Else
.UsedRange.AutoFilter
End If
End With
'Kundenanalyse je Kundenberater
StatusTxt = "Dateien für Kundenberater werden erstellt"
If KundenanalyseKB(lSpalte:=23, DocTitelText:="Kundenberater: ", _
Dateiname1:="VKG-Analyse_", sYYYY_MM:=sEingabe) = False Then GoTo Beenden
'Datei mit Ausgangsdaten wieder schliesseen
wbAusgang.Close
Set wbAusgang = Nothing
Application.StatusBar = False
Application.ScreenUpdating = True
MsgBox "Alle Montsanalysen sind erstellt"
Beenden:
Application.StatusBar = False
If Not wbAusgang Is Nothing Then wbAusgang.Close: Set wbAusgang = Nothing
Set wbRohdaten = Nothing: Set wksRohdaten = Nothing
Set wbAnalyse = Nothing: Set wksAnalyse = Nothing
End Sub
Private Function KundenanalyseRC(lSpalte As Long, DocTitelText As String, _
Dateiname1 As String, sYYYY_MM As String) As Boolean
'In einer Schleife die Kundenanlyse-Datei je Spaltenkriterium erstellen
'lSpalte = Nummer der Spalte mit dem Kriterium, nach dem die Daten _
auf die anderen Dateien verteilt werden sollen
'DocTitelText = Text der in die Dokumenteigenschaften eingebaut wird
'Dateiname1 = 1. Teil des Dateinamens der generierten Dateien
'sYYYY_MM = Text, der in den Dateinamen und die Dokumenteigenschaften _
eingebaut wird.
Dim iCount As Long, oListe As New Collection, oItem, lItem As Long
Dim sDateiAnalyse As String
Dim rngPivot As Range, pvTab As PivotTable, pvField As PivotField, _
pvCache As PivotCache
Dim wksPivot As Worksheet
On Error GoTo Fehler
Application.StatusBar = "Liste der " & StatusTxt & " wird ermittelt"
'Liste der unterschiedlichen Einträge in der Spalte
With wksRohdaten
For iCount = 2 To .Cells(.Rows.Count, lSpalte).End(xlUp).Row
If .Cells(iCount, lSpalte) "" Then
oListe.Add Item:=.Cells(iCount, lSpalte), Key:=CStr(.Cells(iCount, lSpalte))
End If
Next
End With
'Kundenanlysedatei für Regionalzentren erstellen
lItem = 0
For Each oItem In oListe
'Dateiname der Kundenanalyse-Datei
sDateiAnalyse = Dateiname1 & oItem & "_" & sYYYY_MM
lItem = lItem + 1
Application.StatusBar = StatusTxt & ": Datei " & lItem & " von " & oListe.Count _
& " wird erstellt (" & sDateiAnalyse & ")"
'Blatt "MA" der Ausgangsdatendatei in eine neue Arbeitsmappe kopieren
wbAusgang.Sheets("MA").Copy
Set wbAnalyse = ActiveWorkbook
With wbAnalyse
'Weitere Blätter in neue Datei kopieren
wbAusgang.Sheets("Landkreis").Copy after:=.Sheets(.Sheets.Count)
wbAusgang.Sheets("Daten").Copy after:=.Sheets(.Sheets.Count)
'Leeres Tabellenblatt für die Analysedaten am Ende einfügen
.Worksheets.Add after:=.Sheets(.Sheets.Count)
Set wksAnalyse = .Sheets(.Sheets.Count)
'Analyseblatt umbenennen
wksAnalyse.Name = "Kd.-Analyse"
'Dokumenteigenschaften anpassen
.BuiltinDocumentProperties("Title") = DocTitelText & oItem
.BuiltinDocumentProperties("Subject") = "Verkaufsanalyse" & " - " & sYYYY_MM
.BuiltinDocumentProperties("Author") = Application.UserName
.BuiltinDocumentProperties("Manager") = ""
.BuiltinDocumentProperties("Keywords") = ""
.BuiltinDocumentProperties("Comments") = ""
'Datei speichern - schon vorhande Datei gleichen Namens wird ohne Rückfrage _
überschrieben
Application.DisplayAlerts = False
.SaveAs Filename:=sPfad & sDateiAnalyse, FileFormat:=.FileFormat
Application.DisplayAlerts = True
End With
With wksRohdaten
'Titelzeile aus Rohdaten kopieren und formatieren
.Rows(1).Copy Destination:=wksAnalyse.Cells(1, 1)
With wksAnalyse
With .Range(.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft))
.VerticalAlignment = xlBottom
.Orientation = xlUpward
.HorizontalAlignment = xlCenter
.EntireRow.AutoFit
End With
End With
'Fenster in Zelle H2 fixieren
Range("h2").Select
ActiveWindow.FreezePanes = True
'Daten für RC aus Rohdaten übertragen
.AutoFilter.Range.AutoFilter Field:=lSpalte, Criteria1:=oItem
.Range(.Rows(2), .Cells(.Rows.Count, lSpalte).End(xlUp).EntireRow).Copy _
Destination:=wksAnalyse.Cells(2, 1)
End With
With wksAnalyse
'Spaltenbreiten optimieren
.Columns.AutoFit
'Datenbereich für Pivotauswertung
Set rngPivot = .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 2).End(xlUp).Row, _
.Cells(1, .Columns.Count).End(xlToLeft).Column))
'Autofilter aktivieren
rngPivot.AutoFilter
End With
'Pivottabellenbericht(e) einrichten
'Diesen PivotCache könnte man auch für mehrere Pivottabellen nutzen - minimiert die Dateigrö _
ße
Set pvCache = wbAnalyse.PivotCaches.Create(SourceType:=xlDatabase, _
SourceData:=rngPivot, Version:=xlPivotTableVersion11) _
'Die Version ggf. von 11 (Excel 2003) auf eine älere Version setzen)
'Leertabelle für Pivotbericht anfügen
wbAnalyse.Worksheets.Add after:=wksAnalyse
Set wksPivot = ActiveSheet
With wksPivot
.Name = "Pivot"
'Pivottabelle erstellen - Leergerüst
Set pvTab = pvCache.CreatePivotTable(tabledestination:=.Range("A4"), _
Tablename:="Analyse01", _
defaultversion:=xlPivotTableVersion11)
End With
With pvTab
'Felder zum Bericht hinzufügen
.AddFields RowFields:=Array("GBZ", "NameGBZ"), _
ColumnFields:=Array("Deb_passiv", "Int_Inaktiv"), _
PageFields:=Array("PLZ_3", "PLZ_5")
'Datenbereichsfeld(er) einrichten und formatieren
Set pvField = .AddDataField(Field:=.PivotFields("GBZ"), _
Caption:="Anzahl Einträge", _
Function:=xlCount)
With pvField
.NumberFormat = "#.##0"
End With
'Zeilenbereichsfeld(er) formatieren
Set pvField = .RowFields("NameGBZ")
With pvField
.AutoSort Order:=xlAscending, Field:="NameGBZ"
End With
'Spaltenbereichsfeld(er) formatieren
With .ColumnFields("Deb_passiv")
.AutoSort Order:=xlAscending, Field:="Deb_passiv"
End With
With .ColumnFields("Deb_passiv")
.AutoSort Order:=xlAscending, Field:="Int_Inaktiv"
End With
'Summenwerte für Zeilen und Spalten anzeigen ?
.RowGrand = False
.ColumnGrand = True
End With
'Erzeugte Datei speichern und schliessen
wbAnalyse.Save
wbAnalyse.Close
Next
Err.Clear
'Fehler-Behandlung
Fehler:
With Err
Select Case .Number
Case 0 'Alles in Ordnung
KundenanalyseRC = True
Case 457 'Collection-Key wird versucht doppelt zuzuweisen
Resume Next
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbNewLine & .Description
KundenanalyseRC = False
End Select
End With
End Function
Private Function KundenanalyseKB(lSpalte As Long, DocTitelText As String, _
Dateiname1 As String, sYYYY_MM As String) As Boolean
'In einer Schleife die Kundenanlyse-Datei je Spaltenkriterium erstellen
'lSpalte = Nummer der Spalte mit dem Kriterium, nach dem die Daten _
auf die anderen Dateien verteilt werden sollen
'DocTitelText = Text der in die Dokumenteigenschaften eingebaut wird
'Dateiname1 = 1. Teil des Dateinamens der generierten Dateien
'sYYYY_MM = Text, der in den Dateinamen und die Dokumenteigenschaften _
eingebaut wird.
Dim iCount As Long, oListe As New Collection, oItem, lItem As Long
Dim sDateiAnalyse As String
Dim rngPivot As Range, pvTab As PivotTable, pvField As PivotField, _
pvCache As PivotCache
Dim wksPivot As Worksheet
On Error GoTo Fehler
Application.StatusBar = "Liste der " & StatusTxt & " wird ermittelt"
'Liste der unterschiedlichen Einträge in der Spalte
With wksRohdaten
For iCount = 2 To .Cells(.Rows.Count, lSpalte).End(xlUp).Row
If .Cells(iCount, lSpalte) "" Then
oListe.Add Item:=iCount, Key:=CStr(.Cells(iCount, lSpalte))
End If
Next
End With
'Kundenanlysedatei für Regionalzentren/Kundenberater erstellen
lItem = 0
For Each oItem In oListe
'Dateiname der Kundenanalyse-Datei
sDateiAnalyse = Dateiname1 & wksRohdaten.Cells(oItem, 2) & "_" & wksRohdaten.Cells(oItem, _
23) & "_" & sYYYY_MM
lItem = lItem + 1
Application.StatusBar = StatusTxt & ": Datei " & lItem & " von " & oListe.Count _
& " wird erstellt (" & sDateiAnalyse & ")"
'Blatt "MA" der Ausgangsdatendatei in eine neue Arbeitsmappe kopieren
wbAusgang.Sheets("MA").Copy
Set wbAnalyse = ActiveWorkbook
With wbAnalyse
'Weitere Blätter in neue Datei kopieren
wbAusgang.Sheets("Landkreis").Copy after:=.Sheets(.Sheets.Count)
wbAusgang.Sheets("Daten").Copy after:=.Sheets(.Sheets.Count)
'Leeres Tabellenblatt für die Analysedaten am Ende einfügen
.Worksheets.Add after:=.Sheets(.Sheets.Count)
Set wksAnalyse = .Sheets(.Sheets.Count)
'Analyseblatt umbenennen
wksAnalyse.Name = "Kd.-Analyse"
'Dokumenteigenschaften anpassen
.BuiltinDocumentProperties("Title") = DocTitelText & wksRohdaten.Cells(oItem, 23)
.BuiltinDocumentProperties("Subject") = "Verkaufsanalyse" & " - " & sYYYY_MM
.BuiltinDocumentProperties("Author") = Application.UserName
.BuiltinDocumentProperties("Manager") = ""
.BuiltinDocumentProperties("Keywords") = ""
.BuiltinDocumentProperties("Comments") = ""
'Datei speichern - schon vorhande Datei gleichen Namens wird ohne Rückfrage _
überschrieben
Application.DisplayAlerts = False
.SaveAs Filename:=sPfad & sDateiAnalyse, FileFormat:=.FileFormat
Application.DisplayAlerts = True
End With
With wksRohdaten
'Titelzeile aus Rohdaten kopieren und formatieren
.Rows(1).Copy Destination:=wksAnalyse.Cells(1, 1)
With wksAnalyse
With .Range(.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft))
.VerticalAlignment = xlBottom
.Orientation = xlUpward
.HorizontalAlignment = xlCenter
.EntireRow.AutoFit
End With
End With
'Fenster in Zelle H2 fixieren
Range("h2").Select
ActiveWindow.FreezePanes = True
'Daten für Regionalzentrum/Kundenberater aus Rohdaten übertragen
.AutoFilter.Range.AutoFilter Field:=lSpalte, Criteria1:=wksRohdaten.Cells(oItem, 23)
.Range(.Rows(2), .Cells(.Rows.Count, lSpalte).End(xlUp).EntireRow).Copy _
Destination:=wksAnalyse.Cells(2, 1)
End With
With wksAnalyse
'Spaltenbreiten optimieren
.Columns.AutoFit
'Datenbereich für Pivotauswertung
Set rngPivot = .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 2).End(xlUp).Row, _
.Cells(1, .Columns.Count).End(xlToLeft).Column))
'Autofilter aktivieren
rngPivot.AutoFilter
End With
'Pivottabellenbericht(e) einrichten
'Diesen PivotCache könnte man auch für mehrere Pivottabellen nutzen - minimiert die Dateigrö _
ße
Set pvCache = wbAnalyse.PivotCaches.Create(SourceType:=xlDatabase, _
SourceData:=rngPivot, Version:=xlPivotTableVersion11) _
'Die Version ggf. von 11 (Excel 2003) auf eine älere Version setzen)
'Leertabelle für Pivotbericht anfügen
wbAnalyse.Worksheets.Add after:=wksAnalyse
Set wksPivot = ActiveSheet
With wksPivot
.Name = "Pivot"
'Pivottabelle erstellen - Leergerüst
Set pvTab = pvCache.CreatePivotTable(tabledestination:=.Range("A4"), _
Tablename:="Analyse01", _
defaultversion:=xlPivotTableVersion11)
End With
With pvTab
'Felder zum Bericht hinzufügen
.AddFields RowFields:=Array("GBZ", "NameGBZ"), _
ColumnFields:=Array("Deb_passiv", "Int_Inaktiv"), _
PageFields:=Array("PLZ_3", "PLZ_5")
'Datenbereichsfeld(er) einrichten und formatieren
Set pvField = .AddDataField(Field:=.PivotFields("GBZ"), _
Caption:="Anzahl Einträge", _
Function:=xlCount)
With pvField
.NumberFormat = "#.##0"
End With
'Zeilenbereichsfeld(er) formatieren
Set pvField = .RowFields("NameGBZ")
With pvField
.AutoSort Order:=xlAscending, Field:="NameGBZ"
End With
'Spaltenbereichsfeld(er) formatieren
With .ColumnFields("Deb_passiv")
.AutoSort Order:=xlAscending, Field:="Deb_passiv"
End With
With .ColumnFields("Deb_passiv")
.AutoSort Order:=xlAscending, Field:="Int_Inaktiv"
End With
'Summenwerte für Zeilen und Spalten anzeigen ?
.RowGrand = False
.ColumnGrand = True
End With
'Erzeugte Datei speichern und schliessen
wbAnalyse.Save
wbAnalyse.Close
Next
Err.Clear
'Fehler-Behandlung
Fehler:
With Err
Select Case .Number
Case 0 'Alles in Ordnung
KundenanalyseKB = True
Case 457 'Collection-Key wird versucht doppelt zuzuweisen
Resume Next
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbNewLine & .Description
KundenanalyseKB = False
End Select
End With
End Function