Poskládal jsem si makro ktere funguje ale jenom na jednom PC. Na druhem ne a ne to rozchodit. Sesit se otevre a nepovoli se upravy.
Jenom se omlouvam za ten kod nejak jsem to slatal dohromady ale funguje mi to.
Děkuji vsem za pomoc.
Moc se omlouvám za založení noveho vlakna, uz me to funguje. Pouzivam volani maker a priradil jsem spatne makro.
Jeste jednou se omlouvam.
Kód: Vybrat vše
Sub lk()
Application.ScreenUpdating = False
'umístění zdroje (cesta)
ChDir "Z:\Ceník\"
'otevření zdrojového souboru
Workbooks.Open Filename:="Z:\Ceník\ ceník .xlsm"
'název listu
Sheets("Ceník lak").Select
'oblast kopírování ve zdroji
Range("A2:V1000").Select
'příkaz kopírování
Selection.Copy
Application.ScreenUpdating = False
'aktivace cílového souboru
Windows("Ko.xlsx").Activate
ActiveWorkbook.LockServerFile
ActiveWindow.ScrollWorkbookTabs Sheets:=-1
Sheets("lak").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Sheets("lak").Select
Range("A2:V1000").Select
Columns("J:L").Select
Application.CutCopyMode = False
Selection.NumberFormat = "0.00"
Columns("J:L").Select
With Selection
.HorizontalAlignment = xlGeneral
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("A2").Select
Windows("Ko ceník .xlsm").Activate
Range("A2").Select
Windows("Ko.xlsx").Activate
Range("A2:T988").Select
ActiveWorkbook.Worksheets("lak").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("lak").Sort.SortFields.Add2 Key:=Range("A2:A988") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("lak").Sort
.SetRange Range("A1:T988")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A2").Select
Sheets("Ceník Ko").Select
Range("A2").Select
'uzavření cílového souboru
Windows("Ko.xlsx").Activate
'For Each w In Application.Workbooks
' w.Save
' Next w
' Application.Quit
' ActiveWorkbook.Close
'Přejde na první prázdnou bunku
Cells(Rows.Count, 1).End(xlUp).Offset(1).Select
End Sub
