habe die Datei bzw. eigentlich die entsprechenden Markos nun beim Beitrag hochgeladen - ich hoffe das hilft bei der Fehlersuche weiter.
Code:
Private Sub HRM_Dateien_erstellen()
On Error Resume Next
Dim mandant As String
Dim region As String
Dim vbnr As String
Dim debnrdemomaterialvb As String
Dim dateipfad As String
Dim dateiname As String
Dim speicherpfad As String
Dim mrbname As String
Dim mrbpfad As String
Dim hrmdateiname As String
'Richtiges Fenster auswählen
Windows("HRM - MA.xlsm").Activate
'Blattschutz aufheben
Windows("HRM - MA.xlsm").Activate
Call Blatt_Schutz_aufheben
'MA und Parameter einblenden und Blattschutz entfernen
' Sheets("MA").Visible = True
' ActiveWorkbook.Sheets("MA").Unprotect Password:="qawsedrftgmjnhbgvf"
' Sheets("Parameter").Visible = True
' ActiveWorkbook.Sheets("Parameter").Unprotect Password:="qawsedrftgmjnhbgvf"
'Alle Blätter einblenden
Call Blatt_Einblenden_Alle
Call Blatt_Einblenden_VeryHidden
'Blattschutz aufheben
Call Blatt_Schutz_aufheben
'Alle Daten aktualisieren (MA aus CUBE)
Sheets("MA").Select
Range("A2").Select
ActiveSheet.PivotTables("MA").PivotCache.Refresh
'Alle Datenquellen, PowerPivot und einzelne Pivottabellen aktualisieren
ActiveWorkbook.RefreshAll
Calculate
'Letzte gefüllte Zeile in Blatt "MA" Spalte A suchen
Sheets("MA").Select
loletzte = IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)
For loi = 2 To loletzte 'Hier zum testen statt loletzte zB 5 eintragen um nur die ersten 5 auszugeben
'Alle Blätter einblenden
Call Blatt_Einblenden_Alle
Call Blatt_Einblenden_VeryHidden
'Blattschutz aufheben
Call Blatt_Schutz_aufheben
If Sheets("MA").Cells(loi, 2).Value <> "" Then
'Mandant und VBNR auswählen
Sheets("MA").Select
mandant = LCase$(Left(Cells(loi, 3), 3))
region = Cells(loi, 2).Value
vbnr = Cells(loi, 1).Value
debnrdemomaterialvb = LCase$(Left(Cells(loi, 4), 8))
speicherpfad = Cells(loi, 5).Value
mrbname = Cells(loi, 6).Value
mrbpfad = speicherpfad & mrbname
hrmdateiname = speicherpfad & "HRM - " & vbnr & ".xlsm"
'MA - Gebietsanalyse (Mandant und VB übergeben)
'Blattschutz aufheben
Call Blatt_Schutz_aufheben
Sheets("Parameter").Select
ActiveWorkbook.SlicerCaches("Datenschnitt_Debitoren.VB___Gebiet2").VisibleSlicerItemsList = Array("[Customers].[VB - Gebiet].[VB].&[" & mandant & "]&[" & vbnr & "]")
'MA - Artikelfamilie (Mandant und VB übergeben)
ActiveWorkbook.SlicerCaches("Datenschnitt_Debitoren.VB___Gebiet3").VisibleSlicerItemsList = Array("[Customers].[VB - Gebiet].[VB].&[" & mandant & "]&[" & vbnr & "]")
'MA1 (VB übergeben)
ActiveWorkbook.SlicerCaches("Datenschnitt_MA").VisibleSlicerItemsList = Array("[BI_MA_Profit_Center].[MA].&[" & vbnr & "]")
'MA2 (VB übergeben)
ActiveWorkbook.SlicerCaches("Datenschnitt_MA1").VisibleSlicerItemsList = Array("[BI_MA_Profit_Center_Sonstige].[MA].&[" & vbnr & "]")
'MA - TopArtikel und Kunden (Mandant und VB übergeben)
ActiveWorkbook.SlicerCaches("Datenschnitt_Debitoren.VB___Gebiet").VisibleSlicerItemsList = Array("[Customers].[VB - Gebiet].[VB].&[" & mandant & "]&[" & vbnr & "]")
'MA DM-KdnNr: übergeben
Sheets("Artikel - DM").Select
'Vorher eine x-beliebige Kundennummer nehmen damit die aktuelle Nummer nicht ausgewählt ist
ActiveSheet.PivotTables("ArtikelDM").PivotFields( _
"[Customers].[Kunde - Nummer].[Debitor Nummer]").VisibleItemsList = Array( _
"[Customers].[Kunde - Nummer].[Debitor Nummer].&[1-123456]")
'Danach die MA DM-KdnN übergeben
ActiveSheet.PivotTables("ArtikelDM").PivotFields( _
"[Customers].[Kunde - Nummer].[Debitor Nummer]").VisibleItemsList = Array( _
"[Customers].[Kunde - Nummer].[Debitor Nummer].&[" & debnrdemomaterialvb & "]")
'Nochmals alles neu berechnen
Sheets("Balanced Scorecard").Select
Calculate
'Hier werden alle Formeln in Zeile 2 nochmals durchgegangen und aktualisiert
For Each Zelle In Worksheets("Balanced Scorecard").Range("A4:H18").Cells
SendKeys "{F2}", True
SendKeys "{ENTER}", True
Next Zelle
Calculate
Cells(1, 1).Select
'Schriftart hier gleich noch auf Arial 10 setzen
Sheets("Artikel - DM").Select
Range("A4:Z999").Select
With Selection.Font
.Name = "Arial"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
End If
'###########################################################################################################################################################################
'Folgende Blätter ausblenden: "MA", "Parameter", "SonstigeWerte", "--"
Call Blatt_Ausblenden_VeryHidden
'Blattschutz setzen
Call Blatt_Schutz_setzen
'Vorhandene HRM Datei löschen - http://www.office-loesung.de/ftopic66195_0_0_asc.php
If Dir(hrmdateiname) <> "" Then
Kill hrmdateiname
End If
'Datei als Kopie speichern
Application.DisplayAlerts = False
Windows("HRM - MA.xlsm").Activate
ActiveWorkbook.Save
Call Copy_File(vbnr, region, speicherpfad, mrbname, mrbpfad)
Application.DisplayAlerts = True
Next loi
'Alle Blätter einblenden
Call Blatt_Einblenden_Alle
Call Blatt_Einblenden_VeryHidden
'Blattschutz aufheben
Call Blatt_Schutz_aufheben
Sheets("Parameter").Select
Range("A1").Select
End Sub
Public Sub SlicerItemSetzen(objSlicerCache As SlicerCache, ByVal strNameItem As String)
On Error Resume Next
' Datenschnitt - SlicerItem Setzen
Dim objSlicerItem As SlicerItem
Application.ScreenUpdating = False
With objSlicerCache
If .SlicerItems(strNameItem).Selected = False Then
.SlicerItems(strNameItem).Selected = True
End If
For Each objSlicerItem In .VisibleSlicerItems
With objSlicerItem
If .Name <> strNameItem Then
If .Selected = True Then .Selected = False
End If
End With
Next
End With
Application.ScreenUpdating = True
End Sub
Public Sub SicherungskopieSpeichern(dateipfad As String, dateiname As String)
Dim wb As Workbook
Dim ws As Worksheet
Application.DisplayAlerts = False
Set wb = Workbooks.Add
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "MA" And ws.Name <> "Parameter" And ws.Name <> "--" Then
ws.Copy After:=wb.Worksheets(wb.Sheets.Count)
End If
Next
With wb
' Application.DisplayAlerts = False
.Sheets(1).Delete
.SaveAs Filename:=dateipfad & dateiname, FileFormat:=xlOpenXMLWorkbook
' .Close
' Application.DisplayAlerts = True
End With
Windows(dateiname & ".xlsx").Activate
For I = 1 To Sheets.Count - 1
Sheets(I).Select
Cells.Select
'Werte kopieren
Cells.Select
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Sheets(1).Select
Next I
ActiveWorkbook.Close SaveChanges:=1
Application.DisplayAlerts = True
End Sub
Private Sub Einblenden_Blattschutz_entfernen()
Call Blatt_Einblenden_Alle
Call Blatt_Einblenden_VeryHidden
Call Blatt_Schutz_aufheben
Sheets("Parameter").Select
End Sub
Private Sub Ausblenden_Blattschutz_setzen()
Call Blatt_Schutz_setzen
Call Blatt_Ausblenden
Call Blatt_Ausblenden_VeryHidden
Sheets("Balanced Scorecard").Select
End Sub
Private Sub Blatt_Einblenden_Alle()
Dim Blatt As Worksheet
For Each Blatt In Sheets
Blatt.Visible = True
ActiveWindow.ScrollColumn = 1
ActiveWindow.SmallScroll Down:=-100
Range("A1").Select
Next Blatt
End Sub
Private Sub Blatt_Ausblenden()
On Error Resume Next
Sheets(Array("MA", "Parameter", "SonstigeWerte", "--")).Select
ActiveWindow.SelectedSheets.Visible = False
Sheets("Balanced Scorecard").Select
Range("A1:A2").Select
End Sub
Private Sub Blatt_Ausblenden_VeryHidden()
On Error Resume Next
Sheets("MA").Visible = xlVeryHidden
Sheets("Parameter").Visible = xlVeryHidden
Sheets("SonstigeWerte").Visible = xlVeryHidden
Sheets("--").Visible = xlVeryHidden
Sheets("Balanced Scorecard").Select
Range("A1:A2").Select
End Sub
Private Sub Blatt_Einblenden_VeryHidden()
On Error Resume Next
Sheets("MA").Visible = True
Sheets("Parameter").Visible = True
Sheets("SonstigeWerte").Visible = True
Sheets("--").Visible = True
Sheets("Balanced Scorecard").Select
Range("A1:A2").Select
End Sub
Private Sub Blatt_Schutz_setzen()
On Error Resume Next
Dim I As Integer
For I = 1 To Sheets.Count
ActiveWorkbook.Sheets(I).Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:="qawsedrftgmjnhbgvf"
Next
'MsgBox "alle Blätter wurden geschützt"
End Sub
Private Sub Blatt_Schutz_aufheben()
On Error Resume Next
Dim I As Integer
For I = 1 To Sheets.Count
ActiveWorkbook.Sheets(I).Unprotect Password:="qawsedrftgmjnhbgvf"
Next
' MsgBox "alle Blätter wurden vom Blattschutz befreit"
End Sub
Private Sub Copy_File(vbnr, region, speicherpfad, mrbname, mrbpfad)
Dim myFSO As Object
Dim qFolder As String, tFolder As String
Dim qFile As String
Dim tFile As String
'Quellfile
qFile = "HRM - MA.xlsm"
'Quellordner
qFolder = "C:\Temp\HRM\"
'Zielfile
tFile = "HRM - " & vbnr & ".xlsm"
'Zielordner
tFolder = "C:\Temp\HRM\Export\"
tFolder = speicherpfad
'Kill tFolder & qFile
Set myFSO = CreateObject("Scripting.FileSystemObject")
'myFSO.movefile qFolder & qFile, tFolder & qFile
'Alternativ kopieren
myFSO.copyfile qFolder & qFile, tFolder & tFile, True
'In kopierter Datei die Verknüpfungen löschen
'Workbooks.Open Filename:=tFolder & tFile
Application.Workbooks.Open Filename:=tFolder & tFile, UpdateLinks:=True
Windows(tFile).Activate
'Alle Blätter einblenden
Call Blatt_Einblenden_Alle
Call Blatt_Einblenden_VeryHidden
'Blattschutz aufheben
Call Blatt_Schutz_aufheben
'Externe Verknüpfungen löschen
Call Verknüpfungen_löschen
'Abfragen ob es den entsprechenden Mitreisebereicht gibt, zB bei VM's gibt es keine Mitreiseberichte
If Dir(speicherpfad & mrbname) <> "" Then
'Mitreisebericht_Benchmark integrieren
Application.DisplayAlerts = False
Call Mitreisebericht_Benchmark(vbnr, region, speicherpfad, mrbname, mrbpfad, tFile)
Application.DisplayAlerts = True
End If
Windows(tFile).Activate
Sheets("Balanced Scorecard").Select
For Each Zelle In Worksheets("Balanced Scorecard").Range("A4:H18").Cells
SendKeys "{F2}", True
SendKeys "{ENTER}", True
Next Zelle
Calculate
'Externe Datenverbindungen löschen
' Call Datenverbindungen_löschen
'Folgende Blätter ausblenden: "MA", "Parameter", "SonstigeWerte", "--"
Call Blatt_Ausblenden_VeryHidden
'Blattschutz setzen
Call Blatt_Schutz_setzen
Windows(tFile).Activate
Application.DisplayAlerts = False
ThisWorkbook.Saved = True
Workbooks(tFile).Close SaveChanges:=True
Application.DisplayAlerts = True
Windows("HRM - MA.xlsm").Activate
End Sub
Private Sub Verknüpfungen_löschen()
Dim varLinks As Variant
Dim strText As String
If ActiveWorkbook.Name <> "HRM - MA.xlsm" Then
varLinks = ActiveWorkbook.LinkSources(xlExcelLinks)
If IsEmpty(varLinks) Then
' MsgBox "keine Links gefunden!"
Exit Sub
End If
'strText = "Total Links: " & UBound(varLinks) & vbCr
For I = LBound(varLinks) To UBound(varLinks)
' strText = strText & varLinks(i) & vbCr
ActiveWorkbook.BreakLink Name:=varLinks(I), Type:=xlLinkTypeExcelLinks
Next I
'MsgBox strText
Else
Exit Sub
End If
End Sub
Private Sub Datenverbindungen_löschen()
' Verbindungen in aktiver Arbeitsmappe Loeschen
'
Dim wb As Workbook, objConnection As Variant, varAuswahl As Long
Set wb = ActiveWorkbook
If ActiveWorkbook.Name <> "HRM - MA.xlsm" Then
For Each objConnection In wb.Connections
Application.DisplayAlerts = False
objConnection.Delete
Application.DisplayAlerts = True
Next
Else
Exit Sub
End If
End Sub
Private Sub Mitreisebericht_Benchmark(vbnr, region, speicherpfad, mrbname, mrbpfad, tFile)
Windows(tFile).Activate
Sheets("Mitreisbericht-Benchmark").Select
ActiveWorkbook.Sheets("Mitreisbericht-Benchmark").Unprotect Password:="qawsedrftgmjnhbgvf"
'Inhalte löschen (nur Bereich)
Range("A4:Z9999").Select
Selection.ClearContents
Application.Workbooks.Open Filename:=speicherpfad & mrbname, UpdateLinks:=False
Windows(mrbname).Activate
Sheets("Mitreisbericht-Benchmark").Select
ActiveWorkbook.Sheets("Mitreisbericht-Benchmark").Unprotect Password:="qawsedrftgmjnhbgvf"
Sheets("Mitreisbericht-Benchmark").Select
Range("A4:Z9999").Select
Selection.Copy
Windows(tFile).Activate
Sheets("Mitreisbericht-Benchmark").Select
Range("A4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
'Kennwort bei MRB wieder setzen
Windows(mrbname).Activate
Sheets("Mitreisbericht-Benchmark").Select
ActiveWorkbook.Sheets("Mitreisbericht-Benchmark").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:="qawsedrftgmjnhbgvf"
Application.DisplayAlerts = False
Workbooks(mrbname).Close SaveChanges:=False
Application.DisplayAlerts = True
Windows(tFile).Activate
End Sub
Private Sub Workbook_Open()
On Error Resume Next
Workbooks.Open Filename:="I:\Controlling\Controlling\HRM\HRM - MA.xlsm", UpdateLinks:=3
Windows("HRM - MA.xlsm").Activate
Application.Run "'I:\Controlling\Controlling\HRM\HRM - MA.xlsm'!HRM_Dateien_erstellen"
Windows("HRM - MA.xlsm").Activate
End Sub