Speichern in VBA Schlaufe funktioniert nicht
17.05.2017 10:01:35
Philipp
Hallo ich habe ein problem beim speichern von files in einer schlaufe.
Genauer nicht ich habe das problem sondern unser offshore team in polen. Bei mir lāuft das makro problemlos durch. Am pfad kann es meiner meinung nach nicht liegen da dieser angepasst werden kann und auf einen sharedrive referenziert auf den alle zugrif haben.
Danke für eure hilfe
Public FSO As New FileSystemObject
Private Sub Open_FormatBlockLeaveReport()
FormatBlockLeaveReport.Show 0
DoEvents
End Sub
Private Sub Close_FormatBlockLeaveReport()
FormatBlockLeaveReport.hide
End Sub
Private Sub Update_Field_in_FormatBlockLeaveReport(NumFiles As Variant, CurrFile As Variant, _
Directory As Variant, FileNames As Variant)
FormatBlockLeaveReport.FileNumber = NumFiles
FormatBlockLeaveReport.FileStatus = CurrFile & " of " & NumFiles
FormatBlockLeaveReport.FileName = FileNames
FormatBlockLeaveReport.FileDirectory = Directory
FormatBlockLeaveReport.Show 0
DoEvents
End Sub
Sub Summaryreport()
Dim EUA_Application As Workbook 'Workbook where the marcros running out of
Dim Sourcebook As Workbook 'Workbook where we extract data from
Dim Exportsheet As Workbook 'Extracted "Output" from EUA
Dim Summaryreport As Workbook 'Workbook which includes the report where sub report gets created from
Dim GraphicTable As Worksheet 'Sheet which contains the new headers
Dim EUA_Output As Worksheet 'EUA output sheet
Dim Exportoutput As Worksheet 'EUA output sheet after create a new workbook
Dim Home As Worksheet 'Worksheet where you have started the macro and it's shown to the user
Dim Template_Output As Worksheet 'Template which is used as format for the generated summary report
Dim Database As Worksheet 'Summary worksheet in summaryreport
Dim Reference As Worksheet
Dim i As Integer
Dim f As Integer
Dim sname As String
Dim fname As String
Dim vname As String
Dim Referencepath As String 'path to the folder where source files are saved
Dim Target_Referencepath As String 'path to the folder where reformatted files should be saved
Dim Master_Referencepath As String 'path to the folder wehre Masterfile (Summaryreport) should be saved
Dim Sourcefolder As Folder 'folder were source files are saved
Dim xlsbfile As File
Dim IngLastQ As Long
With Application
.AutoCorrect.AutoFillFormulasInLists = False
.AutoCorrect.AutoExpandListRange = False
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
End With
'_____________________________________________________________________________________ Setup for future actions
Set EUA_Application = ActiveWorkbook
Set Home = Worksheets("VBA Set Up")
Home.Unprotect "bbb"
Set Reference = Worksheets("Reference")
Referencepath = Reference.Range("B3").Value 'takes cell B3 as reference to the source folder where the files stored
Master_Referencepath = Reference.Range("B11").Value 'takes cell B11 as reference to the folder where Masterfile (Summaryreport) should be saved
Reference.Range("B7").FormulaR1C1 = _
"=CONCATENATE(""Block Leave Reports_"",RC[1],""_"",RC[2],""_"",RC[3])" 'concatenate the free text with the input from the UserForms and copy/paste that s a value
MkDir Reference.Range("B5").Value & "\" & Reference.Range("B7").Value 'creates folder to store the reformatted BL reports as back up
Set GraphicTable = Worksheets("Graphic_Table")
GraphicTable.Visible = True
Set Template_Output = Worksheets("Template_Output")
Template_Output.Visible = True
Template_Output.copy 'copies the template as a template where future the summaryreport in
Set Summaryreport = ActiveWorkbook
Set Database = ActiveSheet
Database.Name = "Report " & Reference.Range("C7")
Set FSO = CreateObject("Scripting.FileSystemObject") 'creates objects for each file in source folder
Set Sourcefolder = FSO.GetFolder(Referencepath) 'defines input file folder
Target_Referencepath = Reference.Range("B9").Value 'define target folder where files should be stored after reformatting
For Each xlsbfile In Sourcefolder.Files
i = i + 1
Update_Field_in_FormatBlockLeaveReport Sourcefolder.Files.count, i, xlsbfile.Path, xlsbfile.Name
Workbooks.Open FileName:=xlsbfile.Path 'open created object
Set Sourcebook = Workbooks(xlsbfile.Name) 'set the open file as source workbook
Set EUA_Output = Sheets("Output") 'set DIM for output tab and select
EUA_Output.Select
EUA_Output.Shapes.Range(Array("Button 2", "Button 3", "Button 32", _
"Button 20", "Button 25", "Button 26", "Button 33", "Button 27", "Button 29", _
"Button 31", "Button 18")).delete 'delete buttons in output tab
EUA_Output.copy 'extract output and create new workbook
Set Exportsheet = ActiveWorkbook
Set Exportoutput = ActiveSheet
sname = Left(Range("C5").Formula, 4) 'read out OU code for saving the file with
If sname = "" Then
sname = Application.InputBox("Currently loaded file has no OU value entered. Please enter a 4-digit code manually", ("File name"))
End If
Sourcebook.Close savechanges:=False
Exportoutput.Columns("F:CX").Ungroup
Exportoutput.Rows("1:16").delete Shift:=xlUp
EUA_Application.Activate
GraphicTable.Rows("1:1").copy 'move back to EUA and select new headers for the file
Exportsheet.Activate
Exportoutput.Rows("1:1").Insert Shift:=xlDown
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
End With
ActiveWindow.FreezePanes = True 'freeze top row
Exportoutput.Range("U:Y,AG:AG,AJ:AK,BS:CB,CO:CX").delete Shift:=xlToLeft 'delete columns without content & cut OU structure on level 15
IngLastQ = Exportoutput.Range("A1000000").End(xlUp).Row 'defines last row with content in file
Exportoutput.Range("A2:BU" & IngLastQ).copy 'select all rows with content, except the headers
Summaryreport.Activate
Database.Range("A" & Range("A1000000").End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False 'paste the selection into the the first row without content in the Summaryreport
f = 1
fname = Target_Referencepath & "\BL DATA_" & sname & ("_") & Date & ".xlsb" 'create name for file
------------------------------------------------
Excel scheiert an Zeile unten
Exportsheet.SaveAs FileName:=fname, FileFormat:=xlExcel12 'save output file
Exportsheet.Close savechanges:=False
f = i + 1
Set Exportoutput = Nothing
Set Sourcebook = Nothing
Set Exportsheet = Nothing
Next xlsbfile
vname = Master_Referencepath & ("\") & Reference.Range("B7") & ".xlsb" 'create path for Summaryreport file
Database.Range("D:D,E:E,Q:Q,AA:AA").NumberFormat = "m/d/yyyy" 'format output and set font (for the case that other fonts were used before)
Database.Rows("15:15").Select
Database.Range(Selection, Selection.End(xlDown)).Select
With Selection.Font
.Name = "Frutiger 45 Light"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
Database.Range("A15:BV" & Range("A1000000").End(xlUp).Row).RemoveDuplicates Columns:=1, Header:= _
xlNo
Database.Range("A1:C1").Value = Reference.Range("C7") & " " & Reference.Range("D7") & " Block Leave summary report" & Chr(10) & Reference.Range("F7") & " Block Leave year for countries in the following leave year(s): " & Reference.Range("E7")
Database.Range("A3").Value = "Year"
Database.Range("A6").Value = "Block Leave leave year(s):" & Chr(10) & "Associated leave year:"
Database.Range("A4").Value = "Month"
Database.Range("B5").Value = Date
Database.Range("B4").Value = Reference.Range("C7")
Database.Range("B3").Value = Reference.Range("D7")
Database.Range("B6").Value = Reference.Range("F7") & Chr(10) & Reference.Range("E7")
Database.SaveAs FileName:=vname, FileFormat:=xlExcel12 'save output file
Close_FormatBlockLeaveReport 'close info window
GraphicTable.Visible = xlVeryHidden 'hide sheet Graphic_Table
Template_Output.Visible = xlVeryHidden 'hide sheet Template_Output
Reference.Range("C7:F7").ClearContents
EUA_Application.Activate
Home.Protect "bbb"
Home.Select
With Application
.AutoCorrect.AutoFillFormulasInLists = True
.AutoCorrect.AutoExpandListRange = True
.ScreenUpdating = True
.DisplayAlerts = True
End With
msgbox "Data has been successfully reformatted and the summary report is ready for use", 64 'Notification that process has been successfully carried out
Set Sourcefolder = Nothing
Set GraphicTable = Nothing
Set Reference = Nothing
Set Home = Nothing
Set Summaryreport = Nothing
End Sub