Objekt erforderlich - Makro läuft nicht weiter
heidi
mein Makro soll in der function KundenanalyseRC 6 Dateien erstellen. Nach Fertigstellung der ersten Datei kommt jedoch die Fehlermeldung "Objekt erforderlich" und es wird keine zweite Datei mehr erzeugt. Die erzeugte Datei enthält noch ein zusätzliches Sheet mit allen Daten der Ursprungsdatei "Kundenanalyse", welches dort auch nicht mehr sein sollte.
Zuletzt habe ich nur ein paar Kleinigkeiten im Bereich von Pivottabelle erstellen geändert. Davor lief es noch komplett durch.
Kann mir bitte jemand helfen?
Danke und Grüße,
Heidi
'28.01.2011: Angepasster Programmcode für VKG-Analyse vereinzeln; H.Fischer
'Makro läuft, sofern zuvor die Kundenanalyse vom Biztalk-Server geladen wurde,
'Verbindungen gekappt und die Tabelle zu einem Bereich konvertiert wurde.
Option Explicit
Private wbKundenanalyse As Workbook, wksKundenanalyse As Worksheet
Private sPfad As String, sFormel As String
'Private wbAusgang As Workbook
Private wbVKGAneu As Workbook, wksVKGAneu 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
' Datei mit Rohdaten laden (aus gleichem Ordner)
Set wbKundenanalyse = Workbooks.Open(Filename:=sPfad & "Kundenanalyse.xlsx", ReadOnly:=False)
Set wksKundenanalyse = wbKundenanalyse.Worksheets(1) 'Tabellenblatt mit den Rohdaten
'Verzeichnis der Dateien
sPfad = wbKundenanalyse.Path & Application.PathSeparator
'Trennen der Verbindungen zum Biztalkserver in der Kundenanalyse,
'Rücksetzen aller Formatierungen und Tabelle konvertieren in einen Bereich
ActiveSheet.ListObjects("Tabelle_DBAX_AXGH_PRO_h_kundenAnalyse").Unlink
ActiveSheet.ListObjects("Tabelle_DBAX_AXGH_PRO_h_kundenAnalyse").Unlist
'ACHTUNG: AN DIESER STELLE MUSS DIE TABELLE IN EINEN BEREICH KONVERTIERT WERDEN!!
'Ansonsten erscheint immer Fehlermeldung Nr. 91: Objektvariable nicht belegt o.ä.)
Cells.Select
With Selection.Font
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With
Cells.Select
Selection.Style = "Normal"
Range("A1").Select
With wksKundenanalyse
.Activate
.UsedRange.AutoFilter
Cells.Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Cells.Select
With Selection.Font
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With
Cells.Select
Selection.Style = "Normal"
Range("A1").Select
End With
'Datei mit den Ausgangsdaten (Blätter MA,BPL, Landkreis, VKG 2010, Legende) _
schreibgeschützt öffnen
'Wird auskommentiert, da ergänzende Tabellenblätter in Progr.VKG_erstellen abgelegt werden sollen
'Set wbAusgang = Workbooks.Open(Filename:=sPfad & "Test_Ausgangsdatei.xls", ReadOnly:=True)
wbKundenanalyse.Activate
Application.ScreenUpdating = False
'Autofilter in den Rohdaten einrichten
With wksKundenanalyse
.Activate
If .AutoFilterMode = True Then
If .Cells.SpecialCells(xlCellTypeVisible).CountLarge .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 wksKundenanalyse
If .AutoFilterMode = True Then
If .Cells.SpecialCells(xlCellTypeVisible).CountLarge .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
'Wird auskommentiert, da ergänzende Tabellenblätter in Progr.VKG_erstellen
'abgelegt werden sollen
'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 wbKundenanalyse = Nothing: Set wksKundenanalyse = Nothing
Set wbVKGAneu = Nothing: Set wksVKGAneu = 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 wksPivot1 As Worksheet
On Error GoTo Fehler
Application.StatusBar = "Liste der " & StatusTxt & " wird ermittelt"
'Liste der unterschiedlichen Einträge in der Spalte
With wksKundenanalyse
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
'Wird auskommentiert, da ergänzende Tabellenblätter in Progr.VKG_erstellen
'abgelegt werden sollen
Set wbVKGAneu = ActiveWorkbook
With wbVKGAneu
'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 wksVKGAneu = .Sheets(.Sheets.Count)
'Analyseblatt umbenennen
wksVKGAneu.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 wksKundenanalyse
'Titelzeile aus Rohdaten kopieren und formatieren
.Rows(1).Copy Destination:=wksVKGAneu.Cells(1, 1)
With wksVKGAneu
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 I2 fixieren
Range("i2").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:=wksVKGAneu.Cells(2, 1)
End With
With wksVKGAneu
'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 = wbVKGAneu.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
wbVKGAneu.Worksheets.Add after:=wksVKGAneu
Set wksPivot1 = ActiveSheet
With wksPivot1
.Name = "Neukunden"
'Pivottabelle erstellen - Leergerüst
Set pvTab = pvCache.CreatePivotTable(tabledestination:=.Range("A10"), _
Tablename:="Neukunden", _
defaultversion:=xlPivotTableVersion11)
End With
With pvTab
'Felder zum Bericht hinzufügen
.AddFields RowFields:=Array("Stadt_Landkreis_Name"), _
ColumnFields:=Array("Nace_2008"), _
PageFields:=Array("DebInt", "Int_Inaktiv", "Anlagejahr")
'Datenbereichsfeld(er) einrichten und formatieren
Set pvField = .AddDataField(Field:=.PivotFields("DebInt"), _
Caption:="Anzahl Einträge", _
Function:=xlCount)
With pvField
.NumberFormat = "#.##0"
End With
'Zeilenbereichsfeld(er) formatieren
Set pvField = .RowFields("Stadt_Landkreis_Name")
With pvField
.AutoSort Order:=xlAscending, Field:="Stadt_Landkreis_Name"
End With
'Spaltenbereichsfeld(er) formatieren
With .ColumnFields("Nace_2008")
.AutoSort Order:=xlAscending, Field:="NACE_2008"
End With
'Summenwerte für Zeilen und Spalten anzeigen ?
.RowGrand = False
.ColumnGrand = True
End With
'Erzeugte Datei speichern und schliessen
wbVKGAneu.Save
wbVKGAneu.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 wksPivot2 As Worksheet
On Error GoTo Fehler
Application.StatusBar = "Liste der " & StatusTxt & " wird ermittelt"
'Liste der unterschiedlichen Einträge in der Spalte
With wksKundenanalyse
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 & wksKundenanalyse.Cells(oItem, 2) & "_" & wksKundenanalyse. _
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 wbVKGAneu = ActiveWorkbook
With wbVKGAneu
'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 wksVKGAneu = .Sheets(.Sheets.Count)
'Analyseblatt umbenennen
wksVKGAneu.Name = "Kd.-Analyse"
'Dokumenteigenschaften anpassen
.BuiltinDocumentProperties("Title") = DocTitelText & wksKundenanalyse.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 wksKundenanalyse
'Titelzeile aus Rohdaten kopieren und formatieren
.Rows(1).Copy Destination:=wksVKGAneu.Cells(1, 1)
With wksVKGAneu
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 I2 fixieren
Range("i2").Select
ActiveWindow.FreezePanes = True
'Daten für Regionalzentrum/Kundenberater aus Rohdaten übertragen
.AutoFilter.Range.AutoFilter Field:=lSpalte, Criteria1:=wksKundenanalyse.Cells(oItem, 23)
.Range(.Rows(2), .Cells(.Rows.Count, lSpalte).End(xlUp).EntireRow).Copy _
Destination:=wksVKGAneu.Cells(2, 1)
End With
With wksVKGAneu
'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 = wbVKGAneu.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
wbVKGAneu.Worksheets.Add after:=wksVKGAneu
Set wksPivot = ActiveSheet
With wksPivot
.Name = "neue Interessenten"
'Pivottabelle erstellen - Leergerüst
Set pvTab = pvCache.CreatePivotTable(tabledestination:=.Range("A4"), _
Tablename:="Interessenten", _
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
wbVKGAneu.Save
wbVKGAneu.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