Příspěvky uživatele
< návrat zpět
přepsání na .Weight = XlBorderWeight.xlThick nepomohlo...
když to vymažu tak to hodí chybu zase třeba o řádek výše...
ano soubor odkud se to formatuje je uzamčený na heslo ale to mám v makru nastaveno a normálně to všude funguje.
makro je přiřazeno v modulu a přikládám teda ještě makro, které spouštím ale chybu mi to hodí ve dříve přiloženém private sub, zajímavé je, že na starších windows to prostě normálně funguje.
Přikládám konkrétně celý modul v příloze
Private Function doubleLine(aktRange)
Range(aktRange).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlDouble
.ThemeColor = 1
.TintAndShade = -0.499984740745262
.Weight = xlThick
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlDouble
.ThemeColor = 1
.TintAndShade = -0.499984740745262
.Weight = xlThick
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlDouble
.ThemeColor = 1
.TintAndShade = -0.499984740745262
.Weight = xlThick
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlDouble
.ThemeColor = 1
.TintAndShade = -0.499984740745262
.Weight = xlThick
End With
End Function
Sub Model_KPI_RR_tab()
Dim nameFileModel As String, nameFileTab As String
Dim pathFileModel As String, pathFileTab As String
Application.ScreenUpdating = False
Dim nameFile As String, rok1 As String
Dim wksFormats As Worksheet
nameFile = ThisWorkbook.Name
rok1 = Year(Workbooks(nameFile).Worksheets("Tab").Cells(9, "L").Value)
'rok1 = 2018
nameFileModel = "KPI RR " & rok1 & "_Model.xlsx"
nameFileTab = "KPI_RR_" & rok1 & "_UKaR.xlsm"
pathFileModel = "L:\CALL_CENTRUM\CC_TYMY\CC_SPECIALISTE\REPORTY\STATISTIKY\Data\ORKaK - aktualizace\KPI Modely\"
pathFileTab = "L:\CALL_CENTRUM\CC_TYMY\CC_SPECIALISTE\REPORTY\STATISTIKY\Data\ORKaK - aktualizace\KPI Tabulky\"
pathTarget = "M:\CC_DASHBOARDY\2_UKaR\"
Workbooks.Open pathFileModel & nameFileModel, , , , 99, 99
With Workbooks(nameFileModel)
dateModelFirstDen = .Worksheets("Den").Cells(11, 1).Value
dateModelFirstWeek = .Worksheets("Týden").Cells(11, 1).Value
' dateModelFirstMonthS = .Worksheets("Měsíc - sepsané").Cells(11, 1).Value
' dateModelFirstMonthV = .Worksheets("Měsíc - vrácené").Cells(11, 1).Value
dateModelFirstMonthV = .Worksheets("Měsíc").Cells(11, 1).Value
End With
Workbooks.Open pathFileTab & nameFileTab, , , , 99, 99
'Den
Workbooks(nameFileTab).Activate
Sheets("formats").Visible = True
Set wksFormats = Workbooks(nameFileTab).Worksheets("formats")
'zjisti řádek, kam se data budou vkládat
Dim rowTabPasteData As Long, lastRow As Long
Dim rowData As Long
With Workbooks(nameFileTab).Worksheets("Den")
.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
.Outline.ShowLevels RowLevels:=0, ColumnLevels:=2
.Outline.ShowLevels RowLevels:=0, ColumnLevels:=3
.Outline.ShowLevels RowLevels:=0, ColumnLevels:=4
If .Cells(5, 1).Value = "" Then
rowTabPasteData = 5
Else
lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
For rowData = 5 To lastRow
If .Cells(rowData, "A").Value = dateModelFirstDen Then
rowTabPasteData = rowData
GoTo deleteRowsDataDay
End If
Next rowData
rowTabPasteData = rowData
lastRow = lastRow + 1
deleteRowsDataDay:
.Rows(rowTabPasteData & ":" & lastRow).Delete
End If
End With
Dim pomCol As Integer
Dim lastCellAddr As String, lastColAddr As String
'zkopíruje data z modelu (list Den)
With Workbooks(nameFileModel).Worksheets("Den")
pomCol = .Cells(10, Columns.Count).End(xlToLeft).Column
lastCellAddr = .Cells(Rows.Count, pomCol).End(xlUp).Address
.Range("A11:" & lastCellAddr).Copy
End With
'vloží data na list Den
With Workbooks(nameFileTab).Worksheets("Den")
.Activate
.Cells(rowTabPasteData, 1).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Dim startRowColor As Long
'obarví řádky
If .Cells(rowTabPasteData - 2, 1).Interior.TintAndShade = 0 Then
startRowColor = rowTabPasteData - 1
Else
startRowColor = rowTabPasteData
End If
lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
For rowColor = startRowColor To lastRow Step 2
lastColAddr = .Cells(rowColor, Columns.Count).End(xlToLeft).Address
.Range("A" & rowColor & ":" & lastColAddr).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.149998474074526
.PatternTintAndShade = 0
End With
Next rowColor
For rowColor = startRowColor + 1 To lastRow Step 2
lastColAddr = .Cells(rowColor, Columns.Count).End(xlToLeft).Address
.Range("A" & rowColor & ":" & lastColAddr).Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Next rowColor
'nastaví ohraničení
Dim colStartDen As Integer, colEndDen As Integer, rowFormats As Integer, endRowDenFormats As Integer
colStartDen = 1
colEndDen = 2
endRowDenFormats = wksFormats.Cells(Rows.Count, colStartDen).End(xlUp).Row
For rowFormats = 2 To endRowDenFormats
formatRange = wksFormats.Cells(rowFormats, colStartDen).Value & "4:" & wksFormats.Cells(rowFormats, colEndDen).Value & lastRow
doubleLine (formatRange)
Next rowFormats
.Columns("A:B").Font.Bold = True
.Columns("D:D").Font.Bold = True
.Outline.ShowLevels RowLevels:=0, ColumnLevels:=4
.Outline.ShowLevels RowLevels:=0, ColumnLevels:=3
.Outline.ShowLevels RowLevels:=0, ColumnLevels:=2
.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
.Range("M5").Select
End With
'Týden
Workbooks(nameFileTab).Activate
Sheets("formats").Visible = True
'zjisti řádek, kam se data budou vkládat
With Workbooks(nameFileTab).Worksheets("Týden")
.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
.Outline.ShowLevels RowLevels:=0, ColumnLevels:=2
.Outline.ShowLevels RowLevels:=0, ColumnLevels:=3
.Outline.ShowLevels RowLevels:=0, ColumnLevels:=4
If .Cells(5, 1).Value = "" Then
rowTabPasteData = 5
Else
lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
For rowData = 5 To lastRow
If .Cells(rowData, "A").Value = dateModelFirstWeek Then
rowTabPasteData = rowData
GoTo deleteRowsDataWeek
End If
Next rowData
rowTabPasteData = rowData
lastRow = lastRow + 1
deleteRowsDataWeek:
.Rows(rowTabPasteData & ":" & lastRow).Delete
End If
End With
'zkopíruje data z modelu (list Týden)
With Workbooks(nameFileModel).Worksheets("Týden")
pomCol = .Cells(10, Columns.Count).End(xlToLeft).Column
lastCellAddr = .Cells(Rows.Count, pomCol).End(xlUp).Address
.Range("A11:" & lastCellAddr).Copy
End With
'vloží data na list Týden
With Workbooks(nameFileTab).Worksheets("Týden")
.Activate
.Cells(rowTabPasteData, 1).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'obarví řádky
If .Cells(rowTabPasteData - 2, 1).Interior.TintAndShade = 0 Then
startRowColor = rowTabPasteData - 1
Else
startRowColor = rowTabPasteData
End If
lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
For rowColor = startRowColor To lastRow Step 2
lastColAddr = .Cells(rowColor, Columns.Count).End(xlToLeft).Address
.Range("A" & rowColor & ":" & lastColAddr).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.149998474074526
.PatternTintAndShade = 0
End With
Next rowColor
For rowColor = startRowColor + 1 To lastRow Step 2
lastColAddr = .Cells(rowColor, Columns.Count).End(xlToLeft).Address
.Range("A" & rowColor & ":" & lastColAddr).Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Next rowColor
'nastaví ohraničení
colStartDen = 3
colEndDen = 4
endRowDenFormats = wksFormats.Cells(Rows.Count, colStartDen).End(xlUp).Row
For rowFormats = 2 To endRowDenFormats
formatRange = wksFormats.Cells(rowFormats, colStartDen).Value & "4:" & wksFormats.Cells(rowFormats, colEndDen).Value & lastRow
doubleLine (formatRange)
Next rowFormats
.Columns("A:B").Font.Bold = True
.Columns("D:D").Font.Bold = True
.Outline.ShowLevels RowLevels:=0, ColumnLevels:=4
.Outline.ShowLevels RowLevels:=0, ColumnLevels:=3
.Outline.ShowLevels RowLevels:=0, ColumnLevels:=2
.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
.Range("M5").Select
End With
'Měsíc - vrácené
'vymaže všechny záznamy na listu Data
Workbooks(nameFileTab).Activate
Sheets("formats").Visible = True
'zjisti řádek, kam se data budou vkládat
With Workbooks(nameFileTab).Worksheets("Měsíc")
.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
.Outline.ShowLevels RowLevels:=0, ColumnLevels:=2
.Outline.ShowLevels RowLevels:=0, ColumnLevels:=3
.Outline.ShowLevels RowLevels:=0, ColumnLevels:=4
If .Cells(5, 1).Value = "" Then
rowTabPasteData = 5
Else
lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
For rowData = 5 To lastRow
If .Cells(rowData, "A").Value = dateModelFirstMonthV Then
rowTabPasteData = rowData
GoTo deleteRowsDataMonthV
End If
Next rowData
rowTabPasteData = rowData
lastRow = lastRow + 1
deleteRowsDataMonthV:
.Rows(rowTabPasteData & ":" & lastRow).Delete
End If
End With
'zkopíruje data z modelu (list Měsíc - vrácené)
With Workbooks(nameFileModel).Worksheets("Měsíc")
.Activate
pomCol = .Cells(10, Columns.Count).End(xlToLeft).Column
lastCellAddr = .Cells(Rows.Count, pomCol).End(xlUp).Address
.Range("A11:" & lastCellAddr).Copy
End With
'vloží data na list Měsíc - vrácené
With Workbooks(nameFileTab).Worksheets("Měsíc")
.Activate
.Cells(rowTabPasteData, 1).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'obarví řádky
If .Cells(rowTabPasteData - 2, 1).Interior.TintAndShade = 0 Then
startRowColor = rowTabPasteData - 1
Else
startRowColor = rowTabPasteData
End If
lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
For rowColor = startRowColor To lastRow Step 2
lastColAddr = .Cells(rowColor, Columns.Count).End(xlToLeft).Address
.Range("A" & rowColor & ":" & lastColAddr).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.149998474074526
.PatternTintAndShade = 0
End With
Next rowColor
For rowColor = startRowColor + 1 To lastRow Step 2
lastColAddr = .Cells(rowColor, Columns.Count).End(xlToLeft).Address
.Range("A" & rowColor & ":" & lastColAddr).Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Next rowColor
'nastaví ohraničení
colStartDen = 7
colEndDen = 8
endRowDenFormats = wksFormats.Cells(Rows.Count, colStartDen).End(xlUp).Row
For rowFormats = 2 To endRowDenFormats
formatRange = wksFormats.Cells(rowFormats, colStartDen).Value & "4:" & wksFormats.Cells(rowFormats, colEndDen).Value & lastRow
doubleLine (formatRange)
Next rowFormats
.Columns("A:D").Font.Bold = True
.Outline.ShowLevels RowLevels:=0, ColumnLevels:=4
.Outline.ShowLevels RowLevels:=0, ColumnLevels:=3
.Outline.ShowLevels RowLevels:=0, ColumnLevels:=2
.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
.Range("M5").Select
End With
Workbooks(nameFileTab).Worksheets("Den").Activate
Sheets("formats").Visible = xlSheetHidden
Workbooks(nameFileTab).Save
'Workbooks(nameFileTab).Close savechanges:=True
Workbooks(nameFileModel).Close SaveChanges:=True
'Copy Tab z disku L do reportů
fileTarget = pathTarget & nameFileTab
Application.DisplayAlerts = False
Workbooks(nameFileTab).SaveAs fileTarget
Application.DisplayAlerts = True
Application.ScreenUpdating = True
ThisWorkbook.Worksheets("Tab").Cells(15, "S").Value = Date
End Sub
Zdravím, mám takový problém, mám makro které normálně funguje na Windows7 a Office 365 ale na novém notebooku kde je Windows 10 a Office 365 tak toto makro neprojede a vyhodí následující problém s formátováním viz přiložené screeny. Můžete mi někdo poradit jak to obejít aby to fungovalo i na mém novém notebooku?
VBA chybová hláška: Run-time error '1004':
Není možné nastavit vlastnost Weight třídy border
Uživatelské menu
\nMenu
Formulář Faktura
Formulář Faktura IV
Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.
Helios iNuvio
Používáte podnikový systém Helios iNuvio? Potřebujete pomoci se správou nebo vyvinout SQL proceduru? Více informací naleznete na stránce Helios iNuvio.
RSS nejnovější články