Mefisto...diabeł czy anioł?
Witam serdecznie,
adaptujê sobie wcze¶niejsze makro, ale muszê z powodu u¿yszkodników u¿yæ nazw kodowych arkusza. Proszê Was o podpowied¼ co powinienem zmieniæ by makro nie wywala³o siê na lini
With ThisWorkbook.Worksheets(nazwa)
oto ca³y kod:
Option Explicit
Private Sub doArkAll()
Dim WksAll As Worksheet
Dim nazwa As Variant
Dim ostA As Long
Dim ostRazem As Long
Dim i As Long
Application.ScreenUpdating = False
Set WksAll = ThisWorkbook.Worksheets("razem")
With WksAll
ostRazem = .Cells(.Rows.Count, "A").End(xlUp).Row
If ostRazem > 1 Then
.Range("A2:R" & ostRazem).Clear
End If
End With
i = 2
' Ark01 itd to nazwy kodowe moich arkuszy
For Each nazwa In Array(Ark01, Ark02, Ark03, Ark04)
With ThisWorkbook.Worksheets(nazwa)
ostA = .Cells(.Rows.Count, "A").End(xlUp).Row
If ostA > 1 Then
.Range("A2:R" & ostA).Copy
WksAll.Cells(i, "A").PasteSpecial xlPasteValuesAndNumberFormats
i = i + ostA - 1
End If
End With
Next
Application.CutCopyMode = False
Set WksAll = Nothing
Call RefreshPivots
MsgBox "Dane zaktualizowane. Drukuj co trzeba. Mi³ego dnia :)", vbInformation
Application.ScreenUpdating = True
End Sub
Private Sub RefreshPivots()
Dim PC As PivotCache
On Error Resume Next
For Each PC In ThisWorkbook.PivotCaches
With PC
.MissingItemsLimit = xlMissingItemsNone
.Refresh
End With
Next PC
End Sub
Z góry ogromne dziêki
Radek
[ Dodano: 2010-06-09, 10:01 ]
zanotowane.pl doc.pisz.pl pdf.pisz.pl katkaras.opx.pl
adaptujê sobie wcze¶niejsze makro, ale muszê z powodu u¿yszkodników u¿yæ nazw kodowych arkusza. Proszê Was o podpowied¼ co powinienem zmieniæ by makro nie wywala³o siê na lini
With ThisWorkbook.Worksheets(nazwa)
oto ca³y kod:
Option Explicit
Private Sub doArkAll()
Dim WksAll As Worksheet
Dim nazwa As Variant
Dim ostA As Long
Dim ostRazem As Long
Dim i As Long
Application.ScreenUpdating = False
Set WksAll = ThisWorkbook.Worksheets("razem")
With WksAll
ostRazem = .Cells(.Rows.Count, "A").End(xlUp).Row
If ostRazem > 1 Then
.Range("A2:R" & ostRazem).Clear
End If
End With
i = 2
' Ark01 itd to nazwy kodowe moich arkuszy
For Each nazwa In Array(Ark01, Ark02, Ark03, Ark04)
With ThisWorkbook.Worksheets(nazwa)
ostA = .Cells(.Rows.Count, "A").End(xlUp).Row
If ostA > 1 Then
.Range("A2:R" & ostA).Copy
WksAll.Cells(i, "A").PasteSpecial xlPasteValuesAndNumberFormats
i = i + ostA - 1
End If
End With
Next
Application.CutCopyMode = False
Set WksAll = Nothing
Call RefreshPivots
MsgBox "Dane zaktualizowane. Drukuj co trzeba. Mi³ego dnia :)", vbInformation
Application.ScreenUpdating = True
End Sub
Private Sub RefreshPivots()
Dim PC As PivotCache
On Error Resume Next
For Each PC In ThisWorkbook.PivotCaches
With PC
.MissingItemsLimit = xlMissingItemsNone
.Refresh
End With
Next PC
End Sub
Z góry ogromne dziêki
Radek
[ Dodano: 2010-06-09, 10:01 ]