Příspěvky uživatele

Není zač, nevím nakolik je příjemné spouštět kód přes menu maker výběrem, pohodlnější by bylo buď spouštět automaticky při otevření sešitu (případně dotazem na spuštění), nebo přes tlačítko na listu.
Tlačítko by se pak před uložením kopie muselo z listu vymazat.

V příloze varianty.

Řazení jsem přehlédl, upravený kód včetně řazení podle sloupce T a A

Upravený kód (podle návrhu €Ł мσşqμΐτσ).
Snad jsem správně pochopil zadání pro obarvení, neuvádíte co se má obarvit, tak se obarví celý řádek s daty.
Podmínkou je existence souboru ve stejné složce jako je zdrojový soubor makra.

Testy a ošetření chyb (existence souboru atd.) není součástí.

1. Jaká data se mají načítat? Vždy jen 3 řádky z prvního sloupce do tří TextBoxů?
2. bude se s daty nějak dále manipulovat?

Problém je, že ActiveWorkbook.SaveAs uloží stávající XLSM soubor jako XLSX a původní XLSM soubor zůstává beze změny, pokud nebyl ručně uložen před spuštěním makra. Tedy obdoba klasického "Uložit soubor jako".

Nějak jsem nepochopil, co je cílem celého snažení.
Jde o překopírování a přesunutí sloupců ze souboru zdroj.xlsx do jiného definovaného souboru (jméno v proměnné Subor)
K čemu slouží soubor promis.xlsm? Jen ke spuštění makra, nebo to má hlubší význam, kolik obsahuje listů, kolik listů má být uloženo do vytvořeného souboru?
Zdrojový soubor zdroj.xls má vždy tento název? ...

Pokud by byly nějaké ukázky zdrojových a cílových dat jak to má vypadat, asi by se dalo něco napsat. Takhle zbytečně dlouhý kód zde moc na přehlednosti příspěvků a odpovědí nepřidá.

Stačí pár řádků ukázkových dat bez citlivých údajů.

EDIT:
pokud jde o pouhé uložení
'ulozit
Dim WS As Worksheet
Dim Cesta As String, Subor As String, Mesiac As String, Datum As Date
Set WS = Worksheets("makro")
Cesta = ThisWorkbook.Path & "\"
Datum = WS.Cells(1, 2)
Mesiac = Format(Datum, "dd.mm.yyyy")
Subor = Cesta & "Akt OP " & Mesiac & ".xlsx"
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
' Zkopírovat list do nového sešitu
WS.Copy
ActiveWorkbook.SaveAs Filename:=Subor, FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close SaveChanges:=False
' Vymazat data z původního listu
WS.Cells.ClearContents
Set WS = Nothing
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With

ovšem i ostatní kód volá po optimalizaci, zbytečné použití Select a následné Selection, zbytečné opakované cykly pro výmaz řádek splňující podmínky sloučit do jednoho průchodu (v případě velkého objemu dat to způsobí dost velké prodlení) ...

Za sebe bych řešil otevřením zdrojového souboru, překopírováním pouze zájmových sloupců ve správném pořadí (např. podle identifikace v prvním řádku - nadpisy sloupců) a následně uložení takto vytvořeného listu a zavření zdrojového souboru.

Případně lze řešit doplněním vzorců pomocí makra.

Sub DoplnDataZeSouboru()

Dim listCil As Worksheet
Dim cesta As String, soubor As String, listCilJmeno As String
Dim vzorec As String, hodnotaNenalezeno As String
Dim radekDatum As Long, radekDataStart As Long, radekDataKonec As Long
Dim sloupecStart As Long, sloupecKonec As Long
Dim i As Long

Application.DisplayAlerts = False

Set listCil = Worksheets("List1") ' list kam se budou data ukládat
listCilJmeno = "PRAHA" ' jméno zdrojového listu

cesta = ThisWorkbook.Path ' cesta k souborům
radekDatum = 3 ' řádek s datumy (názvy souborů)
radekDataStart = 4 ' první řádek se jmény
sloupecStart = 2 ' první sloupec s datumem
hodnotaNenalezeno = "Nenalezeno" ' text v případě nenalezené shody

With listCil
radekDataKonec = .Cells(Rows.Count, "A").End(xlUp).Row ' poslední obsazený řádek
sloupecKonec = .Cells(radekDatum, Columns.Count).End(xlToLeft).Column ' poslední obsazený sloupec
End With

For i = sloupecStart To sloupecKonec
With listCil
soubor = Format(.Cells(radekDatum, i), "dd.mm.yyyy") & ".xlsx" ' jméno zdrojového souboru
vzorec = "=IFERROR(VLOOKUP(A" & radekDataStart & ",'" & cesta & "\[" & soubor & "]" & listCilJmeno & "'!$B:$Y,23,0),""" & hodnotaNenalezeno & """)" ' vzorec pro SVYHLEDAT

With .Range(.Cells(radekDataStart, i), .Cells(radekDataKonec, i))
.Formula = vzorec ' vloží vzorec
.Value = .Value ' převod na hodnoty
End With
End With
Next i

Application.DisplayAlerts = True

End Sub

Lze i doplnit o test, zda soubor existuje nebo nikoliv.

Pouhé použití s vzorcem s využitím INDIRECT (NEPŘÍMÝ.ODKAZ) vyžaduje otevřený sešit, jinak vrací chybu #ODKAZ

zkusil bych vložit čekací smyčku dokud SAP nedokončí akci

Do While Session.Busy
DoEvents
Loop
mohlo by to pomoci.

Dobrý den,
také jsem dost dlouho řešil tento problém, jak spolehlivě pracovat s jedním souborem pro více uživatelů. Bohužel sdílení nebylo to pravé.
Pokud sešit na cloudu otevře někdo v prohlížeči, nefungují makra, při sdílení v aplikaci platí zásada, kdo poslední provede úpravu buňky, toho změny se zapíší.

Nakonec jsem to celé řešil jedním "datovým" souborem a jedním "ovládacím" souborem.
Oba soubory na sdíleném úložišti mají nastaven atribut pro čtení (ovládací soubor pak bez sdílení může otevřít více uživatelů), datový soubor je pak ve skrytém adresáři.
Celá práce s daty spočívá v načtení dat pro uživatele podle oprávnění. Při ukládání změn do souboru pak kontroluji atribut R datového souboru a případně i čas poslední změny a nově ukládám pouze změny od konkrétního uživatele.

Tohle by po menší úpravě mohlo pro výpis souborů vyhovovat.

Zkusil bych to přes soubor.
Nejprve data uložit do souboru a ten pak otevřít v NotePadu.
Např.:
Sub CopyToNotepad(strText as String)
Dim objFSO As Object
Dim objFile As Object

' Vytvoření objektu FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")

' Vytvoření a otevření textového souboru
Set objFile = objFSO.CreateTextFile("C:\Temp\output.txt", True)

' Zapsání textu do souboru
objFile.WriteLine strText

' Zavření souboru
objFile.Close

' Otevření Notepadu s vytvořeným souborem
Shell "notepad.exe C:\Temp\output.txt", vbNormalFocus
End Sub

Díky, tak tohle zabralo.
A pokud by bylo nutné přidat text ještě za KT jakým příkazem?
.InertAfter "text"

Tak jsem se konečně dostal k testu.
.InsertBreakvyhazuje chybu "Metoda nebo vlastnost není k dispozici, protože je dokument uzamčen pro úpravy."
Domnívám se, že je to "vlastnost" bezpečnostní politiky firmy.

Jediné kdy se mi podařilo vložit KT do textu je: Set WrdDoc = OutMail.GetInspector.WordEditor
shs_kt1.PivotTables("KT1").TableRange1.Copy
WrdDoc.Range.PasteSpecial
ale tam zase narážím na problém, že mi předchozí text vymaže a vkládá tak data "do čistého". Potřebuji vložit text a 4 KT pod sebe.

Spolehlivá metoda je vytvořit ze všech KT samostatný sešit a ten vložit jako přílohu - ovšem pak nesmí nikdo aktualizovat KT v této příloze, protože nenajde zdorj dat.

Jinak naprosto souhlasím s těmi super změnami v MSO u mě též podpořené bezpečnostní politikou. A to netuším co mě bude čekat při přechodu na W11...

Zdravím, potřeboval bych pomoci s makrem, které vloží kontingeční tabulku do textu emailu.

Private Sub OdesliEmailReportu()
' odeslání vytvořeného reportu (KT1 - KT4)

Dim OutApp As Object, OutMail As Object
Dim strAdresat As String, strSubject As String, strBody As String

strAdresat = "adresaprijemce@neco.cz"
strSubject = "Report dne " & Format(Date, "d.m.yyyy")
strBody = "Zasílám vybrané tabulky:"

On Error Resume Next
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo 0

Set OutMail = OutApp.CreateItem(0)

With OutMail
.to = strAdresat
.Subject = strSubject
.body = strBody

.Display
End With

Set OutMail = Nothing
Set OutApp = Nothing

End Sub

KT je uložena na samostatném listu jako KT1
Díky za pomoc

Jediné co mne narychlo napadá je jednorázově spustit:
Sub Email()

Dim hodnota As String
Dim i As Long

With List1
For i = 5 To .Cells(Rows.Count, 1).End(xlUp).Row
hodnota = .Cells(i, 2)
If hodnota <> Empty Then
.Hyperlinks.Add .Cells(i, 2), "mailto:" & hodnota
End If
Next i
End With

End Sub

Příspěvky uživatele

Uživatelské menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje