Hi!
The problem is most likely in the last part of the code.
The code works fine and does its job, but ends a little weird.
Thank you in advance.
Komplete code:
The problem is most likely in the last part of the code.
The code works fine and does its job, but ends a little weird.
Thank you in advance.
Komplete code:
VBA Code:
Sub Comparison()
Dim myFile As String
Dim myFile2 As String
Dim myFile3 As String
Dim myRegneark As String
Dim myRegneark2 As String
Dim myRegneark3 As String
Dim FilePicker As FileDialog
Dim arknavn As String
Dim arknavn2 As String
Dim arknavn3 As String
'Optimize Macro Speed
Application.WindowState = xlMinimized
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
'*******************************
'Velger 3 stk. filer, hvis avbryt hopper den over
'*******************************
Set FilePicker = Application.FileDialog(msoFileDialogFilePicker)
With FilePicker
.Title = "Company © 2020: Velg kalkyle#1"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myFile = .SelectedItems(1)
End With
'Hvis ikke valgt førstefil, avbryt
NextCode:
myFile = myFile
If myFile = "" Then GoTo Stop
Set FilePicker2 = Application.FileDialog(msoFileDialogFilePicker)
With FilePicker2
.Title = "Company © 2020: Velg kalkyle#2"
.AllowMultiSelect = False
.Show
myFile2 = .SelectedItems(1)
End With
Set FilePicker = Application.FileDialog(msoFileDialogFilePicker)
With FilePicker
.Title = "Company © 2020: Velg kalkyle#3"
.AllowMultiSelect = False
.Show
myFile3 = .SelectedItems(1)
End With
'Lage mappe på skrivebordet hvis ikke finnes
Dim path_ As String
path_ = "C:\Users\" & Application.UserName & "\Desktop\Sammenligning - " & Date
Dim path2_ As String
path2_ = "C:\Users\" & Application.UserName & "\Downloads\Sammenligning - " & Date
With CreateObject("Scripting.FileSystemObject")
If Not .FolderExists(path_) Then .CreateFolder path_
If Not .FolderExists(path2_) Then .CreateFolder path2_
If .FolderExists(path2_) Then path_ = path2_
End With
'***********************
'Lagre filer i ny mappe
'***********************
Workbooks.Open Filename:=myFile
myRegneark = ActiveWorkbook.Name
ActiveWorkbook.SaveAs Filename:=path_ & "\" & myRegneark, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Workbooks.Open Filename:=myFile2
myRegneark2 = ActiveWorkbook.Name
ActiveWorkbook.SaveAs Filename:=path_ & "\" & myRegneark2, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Workbooks.Open Filename:=myFile3
myRegneark3 = ActiveWorkbook.Name
ActiveWorkbook.SaveAs Filename:=path_ & "\" & myRegneark3, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
'***********************
'Legge sammenstillings-ark inn i mal
'***********************
Workbooks.Open Filename:=path_ & "\" & myRegneark
arknavn = Left(myRegneark, Len(myRegneark) - 5)
Sheets("Sammenstilling").Select
ActiveSheet.Unprotect (1234)
Sheets("Sammenstilling").Copy After:=Workbooks( _
"Sammenligning_av_kalkark.xlsm").Sheets(1)
Sheets("Sammenstilling").Name = arknavn
Workbooks.Open Filename:=path_ & "\" & myRegneark2
arknavn2 = Left(myRegneark2, Len(myRegneark2) - 5)
Sheets("Sammenstilling").Select
ActiveSheet.Unprotect (1234)
Sheets("Sammenstilling").Copy After:=Workbooks( _
"Sammenligning_av_kalkark.xlsm").Sheets(1)
Sheets("Sammenstilling").Name = arknavn2
Workbooks.Open Filename:=path_ & "\" & myRegneark3
arknavn3 = Left(myRegneark3, Len(myRegneark3) - 5)
Sheets("Sammenstilling").Select
ActiveSheet.Unprotect (1234)
Sheets("Sammenstilling").Copy After:=Workbooks( _
"Sammenligning_av_kalkark.xlsm").Sheets(1)
Sheets("Sammenstilling").Name = arknavn3
'Når alle 3 er ferdige Lagre kopi av sammenligningarket/malen til mappe på skrivebord
ActiveWorkbook.SaveCopyAs (path_ & "\Sammenligning.xlsm")
Workbooks.Open Filename:=path_ & "\Sammenligning.xlsm"
Workbooks("Sammenligning_av_kalkark.xlsm").Close SaveChanges:=False
Windows("Sammenligning.xlsm").Activate
Application.WindowState = xlMaximize
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End
Stop:
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
ActiveWorkbook.Save
Application.Quit
End Sub