Příspěvky uživatele

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

Pr.

Příspěvky uživatele

Uživatelské menu

Menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje