Příspěvky uživatele

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

Prisahám, že nerozumiem funkčnosti celého súboru. Ale terazky už mi fakt dochádza čas ... prchám.

Příspěvky uživatele

Uživatelské menu

Menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje