Příspěvky uživatele
< návrat zpět
Predpokladám, že ste priložil súbor s prílohou XLSM. Ale taký súbor fórum nezoberie. Musíte ho zabaliť do ZIP, ktorý je do cca 256 KB.
Také niečo bude trochu krkolomné.
Do modulu:
Sub StartForm()
UserForm1.Show
End Sub
Do formulára:
Dim aPic() As Shape
Dim cPic As Long
Dim ch As ChartObject
Dim stmpFile As String
Private Sub SpinButton1_Change()
If cPic > -1 Then SetImage aPic(SpinButton1.Value)
End Sub
Private Sub UserForm_Initialize()
Dim SHP As Shape
cPic = -1
For Each SHP In wsObr.Shapes
If SHP.Type = msoPicture Then
cPic = cPic + 1
ReDim Preserve aPic(cPic)
Set aPic(cPic) = SHP
End If
Next SHP
If cPic > -1 Then
Set ch = wstmpgraf.ChartObjects("tmpgraf")
stmpFile = ThisWorkbook.Path & "\pic_tmp.bmp"
SpinButton1.Max = cPic
SetImage aPic(0)
End If
End Sub
Sub SetImage(ByRef SHP As Shape)
SHP.Copy
ch.Select
With ch.Chart
.Paste
.Export stmpFile
End With
Image1.Picture = LoadPicture(stmpFile)
Label1.Caption = SpinButton1.Value
End Sub
Private Sub UserForm_Terminate()
On Error Resume Next
Kill stmpFile
Erase aPic
Set ch = Nothing
End Sub
CodeName listu s obrázkami : wsObr
CodeName skrytého listu s potrebným pracovným grafom : wstmpgraf
Dočasne vytváraný súbor s obrázkom v aktuálnom umiestnení : pic_tmp.bmp
Použiť môžete nejakú univerzálnejšiu metódu, kde je jedno koľko vnorení budete požadovať. Napr. :
Sub Ulozit()
Dim strCesta As String, strJmeno As String, strFolder As String
With wksUvod
strFolder = .Range("D1").Value & "\" & Year(.Range("B3").Value) & "\" & .Range("B2").Value
strJmeno = .Range("B1").Value
End With
VytvorAdresar strFolder
strCesta = strFolder & "\" & strJmeno & ".xlsm"
ThisWorkbook.SaveAs Filename:=strCesta, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
End Sub
Sub VytvorAdresar(Cesta As String)
Dim sC() As String, dC() As String, i As Byte
If Right$(Cesta, 1) <> "\" Then Cesta = Cesta & "\"
dC = Split(Cesta, ":\")
sC = Split(dC(1), "\")
Cesta = dC(0) & ":"
For i = 0 To UBound(sC)
If sC(i) <> "" Then
Cesta = Cesta & "\" & sC(i)
If Len(Dir(Cesta, vbDirectory)) = 0 Then MkDir Cesta
End If
Next i
End Sub
viď tu
Zdroj = "=IF('" & Cesta & "\" & "[" & Nazev & "]" & List & "'!?="""","""",'" & Cesta & "\" & "[" & Nazev & "]" & List & "'!?)"
With Sheets("List1").Range("A1:B2")
.Formula = Replace(Zdroj, "?", "A1")
.Value = .Value
End With
With Sheets("List1").Range("D3:E4")
.Formula = Replace(Zdroj, "?", "D3")
.Value = .Value
End With
Verzia OS a Office ?
OT: Ani nie. Chrbtica ...
Sub Import()
' Import dat z jiného souboru
Dim Cesta As String
Dim Soubor As String
Dim List As String
Dim Zdroj As String
Dim Nazev As String
Cesta = "C:\Users\Downloads"
Nazev = "Zdroj.xlsx"
List = "List1"
Soubor = Cesta & "\" & Nazev
If Dir(Soubor) = "" Then MsgBox "Soubor " & Soubor & " neexistuje!", vbCritical: Exit Sub
Zdroj = "='" & Cesta & "\" & "[" & Nazev & "]" & List & "'!"
With Sheets("List1").Range("A1:B2")
.Formula = Zdroj & "A1:B2"
.Value = .Value
End With
With Sheets("List1").Range("D3:E4")
.Formula = Zdroj & "D3:E4"
.Value = .Value
End With
End Sub
Sub Makro1()
Dim prvy As String, druhy As String, treti As String
Dim PocRia As Long
prvy = "A"
druhy = "G"
treti = "AW"
PocRia = 15
Range("A1").Value = prvy
Range("A2").Value = druhy
Range("A3").Value = treti
Union(Cells(1, prvy).Resize(PocRia), _
Cells(1, druhy).Resize(PocRia), _
Cells(1, treti).Resize(PocRia)).Select
End Sub
Mohla by to byť udalosť listu?
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Range("D2"), Target) Is Nothing Then PageSetup.CenterHeader = Range("D2")
End Sub
ak je to počítaný vzorec, tak napr.
Private Sub Worksheet_Calculate()
PageSetup.CenterHeader = Range("D3")
End Sub
Uveďte ešte verziu Office a jazyk, a aj OS.
Ja mám Office 2019 x64 Pro SK (1808), a Win 10 x64 Pro SK (1909). Nech to môže skúsiť pozrieť niekto, kto má rovnaké podmienky.
Skúste
Range("A2").AutoFilter Field:=1, Criteria1:=Format(Datum, "d.m.yyyy")
@ Stalker :
Kvôli rýchlosti prevedenia, by som na Vašom mieste zvážil "bleskovicu" s aplikovaním dočasného filtra spolu so SpecialCells, napr:
Sub VymazB3()
Dim Radku As Long
Application.ScreenUpdating = False
With Worksheets("List1")
'Počet řádků v A
Radku = .Cells(Rows.Count, "A").End(xlUp).Row
If Radku = 1 Then Exit Sub
With .Range("A1:B" & Radku)
'Dočasně aplikovat filtr
.AutoFilter
.AutoFilter Field:=1, Criteria1:="=N"
On Error Resume Next
'Validní buňky v B smazat najednou
.Columns(2).Resize(Radku - 1).Offset(1, 0).SpecialCells(xlCellTypeVisible).ClearContents
On Error GoTo 0
'Zrušit dočasný filtr
.AutoFilter
End With
End With
Application.ScreenUpdating = True
End Sub
Len teda A1:B1 musí byť hlavička.
Ale on sa neprehľadáva celý stĺpec, ale iba oblasť od 1. po posledný vyplnený riadok. Teda ak sú data od 1 po 80, tak 80 riadkov, ak od 1 po 530 tak 530 riadkov, ak od 1 po 780963 tak ...
Na rýchle určenie slúži tento riadok:
Radku = .Cells(Rows.Count, "A").End(xlUp).Row
Bunka po bunke to proste dlho trvá, a stále sa to s časom spomaľuje. Rozdeliť to na menšie časti, a tie potom spojiť. Príklad:
Sub VymazB2()
Dim Radku As Long, i As Long, A(), rngB As Range, Counter As Long, cRngs As Long, tR() As Range
With Worksheets("List1")
'Počet řádků v A
Radku = .Cells(Rows.Count, "A").End(xlUp).Row
'Načíst data do pole (pokud se načítá pole 1x1 je potřeba nastavit dimenzi)
If Radku = 1 Then ReDim A(1 To 1, 1 To 1): A(1, 1) = .Cells(1, "A").Value Else A = .Cells(1, "A").Resize(Radku).Value
'Cyklem projít pole
For i = 1 To Radku
'Kontrola na "n" i "N"
If StrComp(A(i, 1), "N", vbTextCompare) = 0 Then
Counter = Counter + 1
'Když obsahuje "n" nebo "N", přidej bunku B do oblasti na smazání
If rngB Is Nothing Then Set rngB = .Cells(i, "B") Else Set rngB = Union(rngB, .Cells(i, "B"))
If Counter = 1000 Then cRngs = cRngs + 1: ReDim Preserve tR(cRngs): Set tR(cRngs) = rngB: Set rngB = Nothing: Counter = 0
End If
Next i
End With
'Když oblast na smazání existuje, tak smazat najednou
If Counter + cRngs > 0 Then
For i = 1 To UBound(tR)
If rngB Is Nothing Then Set rngB = tR(i) Else Set rngB = Union(rngB, tR(i))
Next i
If Not rngB Is Nothing Then rngB.ClearContents
End If
End Sub
Sub VymazB()
Dim Radku As Long, i As Long, A(), rngB As Range
With Worksheets("Data")
'Počet řádků v A
Radku = .Cells(Rows.Count, "A").End(xlUp).Row
'Načíst data do pole (pokud se načítá pole 1x1 je potřeba nastavit dimenzi)
If Radku = 1 Then ReDim A(1 To 1, 1 To 1): A(1, 1) = .Cells(1, "A").Value Else A = .Cells(1, "A").Resize(Radku).Value
'Cyklem projít pole
For i = 1 To Radku
'Kontrola na "n" i "N"
If StrComp(A(i, 1), "N", vbTextCompare) = 0 Then
'Když obsahuje "n" nebo "N", přidej bunku B do oblasti na smazání
If rngB Is Nothing Then Set rngB = .Cells(i, "B") Else Set rngB = Union(rngB, .Cells(i, "B"))
End If
Next i
End With
'Když oblast na smazání existuje, tak smazat najednou
If Not rngB Is Nothing Then rngB.ClearContents
End Sub
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