Příspěvky uživatele

@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

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"

Kluci děkuji vám za povzbudivé písmenka a za váš čas

na ADO a SQL se určitě podívám.

Palooo: díky za odkazy a přeji příjemně ztrávenou dovolenou

AL: vzorce jsou taky pro mě těžký oříšek

k zadání ještě: vzoreček se mi líbí, ale nedokážu ho upravit tak aby nalezené hodiny byly v rozmezí těch časů.
t.j. když zadám od6:42 do9:48 tak výsledek hledání nemůže být mimo té množiny.
Výsledek u tvého vzoru je 6:40 ( což je špatně když mám od 6:42)
Výsledek u tvého vzoru je 9:50 ( což je špatně když mám do 9:48)

Zdravím pánove,

potřeboval bych nakopnout

mám csv soubory, kde ve sloupci "A" jsou časy (cca 20 tis až 50tis řádku, záleží jaký den vyberu) viz přílohu
mam vytvořený UF pro zadaní času od-do (třeba od 06:00:00 do 10:30:00)

potřeboval bych vymyslet příkaz, které by mi našlo:
řádek nejbližší k času počátečnímu (od) a
řádek nejbližší k času konečnému (do)

příkaz "find" není to pravé ořechové.

Má prosím někdo nějaký nápad?
Nebo to budu muset cyklovat řádek po řádku?

Příspěvky uživatele

Uživatelské menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje