Příspěvky uživatele
< návrat zpět
Použitie deklarácie Static. Musí byť vo funkcii alebo procedúre. Static ostanú zapamätané aj po skončení makra. Nuluje ich chyba, Stop makra, alebo ZOBRAZENIE VBA EDITORA ! Nesmie byť zobrazený VBA editor!
Funkciu fncCisloNastaveni som urobil tak, že ak sa jej zadá iba 1 číslo, je to pre ňu signál, že má vrátiť danú zapamätanú hodnotu v poradí.
No ak sa jej zadá pole parametrov (daných je podľa požiadavky 13), tak tieto hodnoty zapisuje do svojich uchovávaných Static hodnôt.
Toto vráti 2. uloženú hodnotu spomedzi 13.-ich:
MsgBox fncCisloNastaveni(2)
a toto zapamätá všetkých 13 hodnôt
fncCisloNastaveni 0, 1, 20, 0, 0, 6, 4, 0, 0, 0, 1, 0, 2
(vo forme sú tam Labely)
Skúste, či to bude vyhovovať.
Private Sub Workbook_Open()
Dim R As Long, D(), V() As String, SA As String, SB As String
With ThisWorkbook.Worksheets("List1")
R = .Cells(Rows.Count, "B").End(xlUp).Row
D = .Cells(1, 1).Resize(R, 3).Value
End With
ReDim V(UBound(D, 1) - 1)
For R = 1 To R
If D(R, 3) > 0 Then V(R - 1) = D(R, 2) & D(((R - 1) \ 3) * 3 + 1, 1) & " - " & D(R, 3) & IIf(D(R, 3) = 1, " plná směna", IIf(D(R, 3) < 5, " plné směny", " plných směn"))
Next R
SA = Replace(Join(Filter(V, "Směna A", True), vbCrLf), "Směna A", "")
If SA <> "" Then SA = "Směna A" & vbCrLf & vbCrLf & SA
SB = Replace(Join(Filter(V, "Směna B", True), vbCrLf), "Směna B", "")
If SB <> "" Then SA = IIf(SA = "", "", SA & vbCrLf & vbCrLf) & "Směna B" & vbCrLf & vbCrLf & SB
If SA <> "" Then MsgBox SA, vbExclamation, "Přehled plných směn."
End Sub
Pozerám u kolegu vyššie - dobrý nápad s tými Tabulátormi. Úprava s nimi:
Private Sub Workbook_Open()
Dim R As Long, D(), V() As String, SA As String, SB As String
With ThisWorkbook.Worksheets("List1")
R = .Cells(Rows.Count, "B").End(xlUp).Row
D = .Cells(1, 1).Resize(R, 3).Value
End With
ReDim V(UBound(D, 1) - 1)
For R = 1 To R
If D(R, 3) > 0 Then V(R - 1) = vbTab & D(R, 2) & D(((R - 1) \ 3) * 3 + 1, 1) & vbTab & D(R, 3) & IIf(D(R, 3) = 1, " plná směna", IIf(D(R, 3) < 5, " plné směny", " plných směn"))
Next R
SA = Replace(Join(Filter(V, "Směna A", True), vbCrLf), "Směna A", "")
If SA <> "" Then SA = "Směna A :" & vbCrLf & SA
SB = Replace(Join(Filter(V, "Směna B", True), vbCrLf), "Směna B", "")
If SB <> "" Then SA = IIf(SA = "", "", SA & vbCrLf & vbCrLf) & "Směna B :" & vbCrLf & SB
If SA <> "" Then MsgBox SA, vbExclamation, "Přehled plných směn."
End Sub
Som len na mobile, skúste dať prílohu s ukážkou vzorcov. Bude potrebné použiť VLOOKUP v prevodnej tabuľke, a vzorce nálezite upraviť.
Sub Group_Click()
MsgBox Worksheets("Hárok1").Shapes(Application.Caller).ParentGroup.Name
End Sub
Základom je:
-Nastavené rovnaké makro pre všetky prvky všetkých skupín.
-Pozor! Nefunguje, ak sa vytvárajú ďalšie skupiny kopírovaním. Musí sa každá skupina sama o sebe Zoskupiť.
-GroupNmae vráti ENG názov skupiny, nie ten, čo Vám predvolene ukazuje CZ/SK mutácia Excelu v "Tabla Výberu". Tam si ich premenujte na nejaké zmysluplné, a potom makro vráti už to premenované.
O koľko rôznych číselných hodnôt má ísť? Ak iba o pár, dá sa to pomocou Vlastného formátu + Podmienený formát. Pomocou PF sa zadá VF vždy s dvomi podmienkami. Zobrazovať to bude ako chcete, vzorce budú fungovať ale počítať budú aj s číslami mimo číselnú oblasť, ktorú to pozná. Teda ráta sa aj s tou 50 v A9, ktorú VF ani PF nepozná.
Nič iné ma nenapadlo 
@ dejv351: len doplním - dajte si pozor na medzery pred menami. Ak budete robiť nejaké dohľadávania či sumár, nebude Vám to sedieť ("Pavel" nie je " Pavel").
Tak som to určo nemyslel. Písané slovo má nevýhodu absencie intonácie, čo často mení zamýšľaný význam. Neva.
Napadlo nás inak presne to isté. Riešení je určo hafo.
Tvoj postup u mňa funguje.
OT : Inak mne Excel aj Win blbne tiež. A žiaľ často. Ale už sa tomu strojím v blízkej dobe zakrútiť krkom, keď sa mi zdravotne polepší. Ako si písal minule k Vianociam, aby sme boli negatívni, tak som ti aj chcel napísať, že som negatívny testom, ale zároveň aj negatívne naladený. Posunuté 2 platničky na krku, 2 na krížoch, pre covid odložená operácia potrhaného menisku v ľavom kolene, na pravej nohe som si zlomil palec, nemôžem poriadne chodiť, sedieť ani ležať, hroziace vyberanie krčných mandlí, zlomil sa mi zub, covid ma obstreľuje už z každej strany (som imuno pacient), a choďte terazky po doktoroch ... Tak ak napíšem dakomu nejakú čovinu, len pls mávnite rukou, nemyslím to zle, som iba negatívny alias nasraný 
@Stalker: Nerozumiem presne, prečo tam máte oblasť INDEX($C$3:$K$1342...
Stačí
=IFERROR(INDEX(C3:K3;;MAX(IF(C3:K3<>0;COLUMN(C3:K3)))-2);"")
=IFERROR(INDEX(C3:K3;;MAX(KDYŽ(C3:K3<>0;SLOUPEC(C3:K3)))-2);"")
prípadne obyčajný nematicový vzorec
=IFERROR(LOOKUP(2;1/(C3:K3<>"");C3:K3);"")
=IFERROR(VYHLEDAT(2;1/(C3:K3<>"");C3:K3);"")
alebo rovnako nematicový
=IFNA(INDEX(C3:K3;MATCH(0;C3:K3;-1));"")
=IFNA(INDEX(C3:K3;POZVYHLEDAT(0;C3:K3;-1));"")
Skúste maticový vzorec
=SUM((IFERROR(SEARCH("; "&A2&";";"; "&Karty!$C$2:$C$100&";");0)>0)*1)
=SUMA((IFERROR(HLEDAT("; "&A2&";";"; "&Karty!$C$2:$C$100&";");0)>0)*1)
Toto máte určite zle technicky:
Sheets("Nabídka").Range(("B" & Radek), Range("B:BG" & Radek)).Copy
má to byť
Sheets("Nabídka").Range("B" & Radek & ":BG" & Radek)
a navyše ak nemajú listy rovnaké údaje na rovnakých riadkoch, tak je to zle aj logicky. Musel by ste použiť 2. cyklus. Keď jeden by bral vždy po jednom DATA a druhý cyklus by pre každý DATA riadok prešiel celú NABIDKA. To je zbytočne pomalé, preto som použil hromadný maticový MATCH/POZVYHLEDAT v Evaluate ("vyhodnocovač vzorcov").
Bola by dobrá príloha, kde by bolo vidieť, či sa jedná o rovnaké riadky, rovnaký počet riadkov, a či je vôbec potrebné kopírovať xlPasteAll, alebo by stačilo iba hodnoty. Ale je pravda, že to by som Vám zase iba skomplikoval kód :)
Oprava, zabudol som na korekciu v prípade, ak bude kontrolovaný iba 1 riadok, vtedy nevráti Evaluate pole ale iba hodnotu - opravené:
Sub Najdi_kopiruj()
Dim RadkuN As Long, RadkuD As Long, i As Long, aFind
Application.ScreenUpdating = False
RadkuD = Worksheets("Data").Cells(Rows.Count, 1).End(xlUp).Row
If RadkuD = 1 Then MsgBox "Žádné data.", vbExclamation: Exit Sub
With Worksheets("Nabídka")
RadkuN = .Cells(Rows.Count, 1).End(xlUp).Row
If RadkuN = 1 Then MsgBox "Žádné nabídky.", vbExclamation: Exit Sub
aFind = Evaluate("=IFNA(MATCH('Data'!N2:N" & RadkuD & ",'Nabídka'!A2:A" & RadkuN & ",0),0)")
If IsArray(aFind) Then
For i = 1 To RadkuD - 1
If aFind(i, 1) > 0 Then .Range("B1:BG1").Offset(aFind(i, 1), 0).Copy Worksheets("Data").Cells(i + 1, "BY")
Next i
Else
If aFind > 0 Then .Range("B2:BG2").Copy Worksheets("Data").Cells(1, "BY")
End If
End With
Application.ScreenUpdating = True
End Sub
Neviem, či Vás chápem ... skúste iný prístup:
Sub Najdi_kopiruj()
Dim RadkuN As Long, RadkuD As Long, i As Long, aFind
Application.ScreenUpdating = False
RadkuD = Worksheets("Data").Cells(Rows.Count, 1).End(xlUp).Row
If RadkuD = 1 Then MsgBox "Žádné data.", vbExclamation: Exit Sub
With Worksheets("Nabídka")
RadkuN = .Cells(Rows.Count, 1).End(xlUp).Row
If RadkuN = 1 Then MsgBox "Žádné nabídky.", vbExclamation: Exit Sub
aFind = Evaluate("=IFNA(MATCH('Data'!N2:N" & RadkuD & ",'Nabídka'!A2:A" & RadkuN & ",0),0)")
For i = 1 To RadkuD - 1
If aFind(i, 1) > 0 Then
.Range("B1:BG1").Offset(aFind(i, 1), 0).Copy Worksheets("Data").Cells(i + 1, "BY")
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
A priložte prílohu.
OT:
@marjankaj: Presne toto dodržiavam Najskôr všetky možnosti vyskúšam, preštelujem, potom googlujem, potom kontakt známych, no a potom ... potom príde manželka a spraví to 
EDIT: Inak ma napadá, ak by mali stĺpce hlavičky, a niekde by mohli byť 2 bunky s parametrom pre Rozšírený filter, tak stačí:
Sub Rozsireny_Filter()
Worksheets("List1").Range("A1:B141").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Worksheets("List1").Range("D1:D2"), CopyToRange:=Worksheets("List2").Range("A1"), Unique:=False
End Sub
Ešte sa mi za tie roky nestalo že by vo VBA mal integer či long inú default ako 0, alebo boolean po deklarácii nemal False, či nedajbože Range nemala Nothing, alebo string nemal "".
Ešte nejaký ten zdroj...
Ak sú to susedné bunky, kopírujte ich naraz obe:
Sub kopiruj()
Dim i As Integer, j As Integer
'zkopíruje A1:A140 pokud > 0
For i = 1 To 140
With Worksheets("List1").Cells(i, 2)
If .Value > 0 Then
j = j + 1
Worksheets("List2").Cells(j, 1).Resize(, 2) = .Offset(0, -1).Resize(, 2).Value
End If
End With
Next i
End Sub
A ešte rýchlejšie cez pole (ale tu sa jedná o máličko údajov, takže asi zbytočné...)
Sub kopiruj2()
Dim i As Integer, j As Integer, D(), V()
D = Worksheets("List1").Range("A1:B140").Value
'zkopíruje A1:A140 pokud > 0
For i = 1 To 140
If D(i, 2) > 0 Then
j = j + 1
ReDim Preserve V(1 To 2, 1 To j)
V(1, j) = D(i, 1): V(2, j) = D(i, 2)
End If
Next i
If j > 0 Then Worksheets("List2").Range("A1").Resize(j, 2).Value = Application.Transpose(V)
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