< návrat zpět

MS Excel

Téma: Windows10 problém s makrem rss

Zaslal/a AlesD6 13.7.2020 13:27

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

Příloha: jpg47275_makro-chyba.jpg (56kB, staženo 68x)
47275_makro-chyba.jpg
Zaslat odpověď >
Palooo(24.7.2020 11:12)#047446
avatar
divne malo by to fungovat ale kedze to patri triede: XlBorderWeight

skuste ten riadok prepisat na .Weight = XlBorderWeight.xlThick

alebo aby vam to aspon fungovalo tak ten riadok vsade vymazte .... tj. vam to len neoramuje s tenkou ciarou ale defaultne co je asi medium ciara.

popripade skuste zapnut record macro a tam naformatovat nejaku oblast a potom sa pozriet do makra ako to tam ulozilo.citovat
Palooo(24.7.2020 11:17)#047447
avatar
este jedna moznost ma napadlo nemate uzamknutu oblast ktoru chcete formatovat?citovat
robert13(24.7.2020 12:11)#047449
avatar
Si si istý, že to fungovalo v tvare, akom uvádzaš?
Nemalo byť namiesto Private Function použité Sub?citovat
elninoslov(27.7.2020 8:41)#047469
elninoslov
W10 x64 Pro SK, Office 2019 Pro x64 SK - makro funguje.
Ako bolo napísané, to nieje funkcia s návratovou hodnotou - teda má to byť procedúra sub.
Je v liste alebo v module?
Volá sa z listu alebo z mobulu?
Alebo je v PERSONAL.XLSB?
Čo má vstupovať ako parameter, string alebo Range?
Určite by som vynechal Select...
Príloha by bodla.
Sub doubleLine(aktRange As Range)
With aktRange
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlDouble
.Weight = xlThick
End With
With .Borders(xlEdgeTop)
.LineStyle = xlDouble
.Weight = xlThick
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlDouble
.Weight = xlThick
End With
With .Borders(xlEdgeRight)
.LineStyle = xlDouble
.Weight = xlThick
End With
End With
End Sub
Sub pokus()
doubleLine Worksheets("Hárok1").Range("B3:D10")
End Subcitovat
AlesD6(5.8.2020 14:01)#047601
avatar
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
citovat
marjankaj(5.8.2020 14:13)#047602
avatar
Stále si neprezradil, ako to voláš? Z listu, alebo z VBA?

Možno ti unikol rozdiel medzi SUB a FUNCTION.citovat

Uživatelské menu

Nejste přihlášen(a)
avatar\n

Menu

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.

On-line nástroje