Příspěvky uživatele
< návrat zpět
eLCHa napsal/a:
mno, on už to napsal přede mnou lubo ;))
a když se trošku zasoustředím - tak ten váš kód ještě trochu zredukuji ;))
Sub PChartsRefresh()
Sheets("KT-G").PivotTables(1).PivotCache.Refresh
End Sub
v podstatě bych ho vymazal úplně - pokud to není součást jiného většího projektu ;))
jj ted je to luxusní. Nemusím už nijak dál řešit průřezi.
Děkuji Vam všem ještě jednou, konečne se můžu pohnout po třech týdnech dál
eLCHa napsal/a:
Co myslíte změnou?
Změnou dat - mně to funguje
Změna oblasti - musíte pořešit nebo nejlépe převeďte na tabulku (Vložení - Tabulka) a starat se o to nemusíte
tak tohle jsem potřeboval
Tisíc krát díky. Teď to funguje přesně jak má.
Ještě jednou díky
@eLCHa:
po odstranění .PivotCaches.Create... se teď neaktulizuje tabulka, pokud udělám zmenu v source datech. 
Vypinání KT jsem udělal jenom narychlo, aby mi to nehazelo do chyby, ale to nemá vliv na aktualizaci. Alespoň si to myslím.
@Lubo: Verze 2010
@eLCHa:
Makro jsem přepsal, refresh jsem z cyklu vyndal, sešit znovu vytvořil viz příloha. Ale vše beze změn 
Pruřez pred aktualizací vypínam
mepexg napsal/a:
for each ...
ActiveSheet.pt.PivotCache.Refresh
next
@mepexg:
Děkuji za příspěvek, ale bohužel ani tohle nepomáhá.
Tohle nakopíruj do Listu4 "CELKOVÝ SEZNAM OVOCE I ZELENINY"
kde při každém přepnutí se makro spustí.
Private Sub Worksheet_Activate()
Dim Prdk As Long, Krdk As Long
With List4 'Jmeno cílového listu "CELKOVÝ SEZNAM OVOCE I ZELENINY"
Prdk = 4 ' počátční řádek v cilovém listu
Krdk = .Cells(Cells.Rows.Count, 2).End(xlUp).Row ' Poslední řádek v cilovém listu
.Range(.Cells(Prdk, 2), .Cells(Krdk, 3)).Delete 'Odstraní seznam v cílovem listu
List1.Range(List1.Cells(2, 1), _
List1.Cells(List1.Cells(Cells.Rows.Count, 2).End(xlUp).Row, 2)).Copy .Cells(Prdk, 2) 'Kopirování seznamu z první tabulky
Prdk = .Cells(Cells.Rows.Count, 2).End(xlUp).Row + 1
List2.Range(List2.Cells(2, 1), _
List2.Cells(List2.Cells(Cells.Rows.Count, 2).End(xlUp).Row, 2)).Copy .Cells(Prdk, 2) 'Kopirování seznamu z druhé tabulky
End With
End Sub
Ahoj,
nikoho nenapadá jak aktualizovat makrem zdroj dat v kontingenční tabulkách, tak aby se v průřezech neztrácely tabulky?
Omlouvám se,
Průřez před aktualizaci a Průřez po aktualizaci viz příloha.
Ahoj
už delší dobu se snažím vyřešit problém s aktualizací kontingenčních tabulek pomocí VBA.
Problém spočívá v tom, že po aktualizaci makrem, (viz níže) se v průřezu ztratí výběr jedné z tabulek.
Průřez před aktualizací:
Makro:
Dim oblt As Range
Dim pt As PivotTable
Dim oblast As String
Set oblt = Data.Range("A1").CurrentRegion
oblast = Data.Name & "!" & oblt.Address(ReferenceStyle:=xlR1C1)
For Each pt In Sheets("Tables").PivotTables
pt.ChangePivotCache ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=oblast)
pt.RefreshTable
Next pt
Set oblt = Nothing
Průřez po aktualizaci:
Ale až když aktualizuji manuálně (Nástroje kontingenční tabulky => Možnosti => Změnit zdroj dat = > Změnit zdroj dat…) obě tabulky, tak se v průřezu ukážou zase obě tabulky.
Za každou radu budu vděčný.
Děkuji
MS
Ahoj, pokud jsem to správně pochopil, tak stačí přidat příkaz mezi řádky. Viz níže.
If IsError(Application.Match(sh.Name, _
Array(DestSh.Name, "Information"), 0)) Then
sh.Cells.AutoFilter 5, "Slovo"
'Find the last row with data on the DestSh and sh
Last = LastRow(DestSh)
shLast = LastRow(sh)
Ahoj,
když se jedná jenom o jeden sloupec tak použij makro viz níže a když více sloupců tak by bylo jednodušší poslat přílohu
Private Sub CommandButton1_Click()
'Vložit obrázek do komentáře buňky
Dim sloupec, bunka
Dim Cesta As String
Dim Pripona As String
Dim FileName As String
Dim cmt As Comment
Dim dWidth As Double
Dim dHeight As Double
Cesta = "C:\Users\Mosquito\Desktop\blabla\" 'sem zadat cestu kde se fotky nachází
Pripona = ".jpg" 'sem zadat správnou příponu
sloupec = 1 ' sloupec = císlo sloupce (v tomhle pripade 1 je sloupec A)
For Each bunka In Range(Cells(1, sloupec), Cells(Rows.Count, sloupec).End(xlUp))
If Not bunka = Empty Then
FileName = Cesta & bunka & Pripona
On Error Resume Next
'Zjištění rozměrů obrázku
ActiveSheet.Pictures.Insert(FileName).Select
dWidth = Selection.Width
dHeight = Selection.Height
Selection.Delete
'Vložení obrázku do komentáře
With bunka
Set cmt = .Comment
If cmt Is Nothing Then
Set cmt = .AddComment
End If
With cmt
.Text Text:=""
.Shape.Fill.UserPicture FileName
.Shape.Width = dWidth
.Shape.Height = dHeight
.Visible = False
End With
End With
On Error GoTo 0
End If
Next bunka
End Sub
Ahoj,
jenom jsem trochu zkrátil a upravil zacatek makra
Private Sub CommandButton1_Click()
'Vložit obrázek do komentáře buňky
Dim Cesta As String
Dim Pripona As String
Dim FileName As String
Dim cmt As Comment
Dim dWidth As Double
Dim dHeight As Double
Cesta = "C:\Users\czprsm03\Pictures\" 'sem zadat cestu kde se ta fotka nachází
Pripona = ".jpg" 'sem zadat správnou příponu fotky
FileName = Cesta & ActiveCell & Pripona
'Zjištění rozměrů obrázku
ActiveSheet.Pictures.Insert(FileName).Select
dWidth = Selection.Width
dHeight = Selection.Height
Selection.Delete
'Vložení obrázku do komentáře
On Error Resume Next
With ActiveCell
Set cmt = .Comment
If cmt Is Nothing Then
Set cmt = .AddComment
End If
With cmt
.Text Text:=""
.Shape.Fill.UserPicture FileName
.Shape.Width = dWidth
.Shape.Height = dHeight
.Visible = False
End With
End With
End Sub
ale tohle ti vytváří stále nové grafy.
zkus takhle
Dim oblst As Range
Sub Makro1()
Set oblst = List1.Range("B2:F11")
ActiveSheet.Shapes.AddChart.Select
ActiveChart.SetSourceData oblst
ActiveChart.ChartType = xlLine
Set oblst = Nothing
End Sub
Sub Makro2()
Set oblst = List1.Range("B2:B11,D2:D11,F2:F11")
ActiveSheet.Shapes.AddChart.Select
ActiveChart.SetSourceData oblst
ActiveChart.ChartType = xlLine
Set oblst = Nothing
End Sub
AL:
děkuji ti.
tohle je přesně co potřebuji
já blázen se snažil vzorečkům co nejvíc vyhýbat a řešit všechno vba a teď mám mezery 
třeba
Range("A1:A20").NumberFormat = "0"
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