Excel Forum - Porady, Pomoc, Excel Help, Excel FAQ - 2 poziomowe dynamiczne Context Menu

kloszuu · Stały bywalec Excelforum **Pomógł:** 1 raz Posty: 253

Witam,

Chciałbym prosić o pomoc przy zrobieniu dwu pozimowego Context Menu, musi ono być dynamiczne i tworzone na postawie wartości z dwóch kolumn. Przedstawię to na prostym przykładzie asortymentu sklepowego.

W załączonym Pliku mamy trzy poziomy:

Poziom podstawowy (Poziom 0): Jest to ogólny Asortymenty
Poziom 1: Kategorie: Warzywa; Owoce, Nabiał, Pieczywo
Poziom2: Poszczególne artykuły przynależne do tych kategorii.

Po przyciśnięciu prawego przycisku myszy jak widać takie Menu jest tworzone natomiast nie jest ono dynamiczne, a to jest mój główny problem ponieważ zarówno kategorie będę ulegały zmianie jak i artykuły w tych kategoriach. Czy jest możliwe stworzenie takiego menu żeby automatycznie się dostosowywało w zależności od wartości jakie użytkownik wprowadzi w tych poszczególnych kolumnach odpowiadających Pomowi 1 i 2?

Przy tworzeniu Menu musza byc wybierane tylko unikatowe wartosci kategorii. Uzytkownicy beda dodawali nowe artykuly wedlug schematu tabelki przedstawionego w pliku.

Wisienka na torcie by już było gdy jeszcze one były ułożone alfabetycznie.

Pozdrawiam i dziekuje

Piotrek

Przyklad Menu.xlsm

Pobierz Plik ściągnięto 13 raz(y) 21.34 KB

Czeslaw · **Pomógł:** 279 razy Posty: 931

Power Query

Kod:

let
Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
#"Grouped Rows" = Table.Group(Source, {"Poziom1"}, {{"Count", each _, type table [Poziom1=text, Poziom2=text]}}),
#"Added Custom" = Table.AddColumn(#"Grouped Rows", "Custom", each Table.AddIndexColumn([Count],"Index",1,1)),
#"Expanded Custom" = Table.ExpandTableColumn(#"Added Custom", "Custom", {"Poziom1", "Poziom2", "Index"}, {"Poziom1.1", "Poziom2", "Index"}),
#"Removed Columns1" = Table.RemoveColumns(#"Expanded Custom",{"Poziom1", "Count"}),
#"Pivoted Column" = Table.Pivot(#"Removed Columns1", List.Distinct(#"Removed Columns1"[Poziom1.1]), "Poziom1.1", "Poziom2"),
#"Removed Columns2" = Table.RemoveColumns(#"Pivoted Column",{"Index"})
in
#"Removed Columns2"

Przyklad Menu(1).xlsm

Pobierz Plik ściągnięto 7 raz(y) 30.46 KB

kloszuu · Stały bywalec Excelforum **Pomógł:** 1 raz Posty: 253

Dziekuje za odpowiedz natomiast tego typu rozwiaznie nie moge zaimplementowac do VBA zeby utworzyc Menu dostepne po kliknieciu prawego przycisku myszy tak jak to bylo pokazane w zalaczonym przykladzie.

przyklad.jpg

Plik ściągnięto 16 raz(y) 78.29 KB

Tajan · **Pomógł:** 5548 razy Posty: 12042

Procedury w Module1 zamień na taki kod:

Kod:

Option Explicit

Dim dane As Object

Sub AddItemContextMenu()
Dim ContextMenu As CommandBar
Dim MojeMenu As CommandBarControl
Dim i As Long, j As Long

InitializeMenuData

Application.CommandBars("Cell").Reset

Set ContextMenu = Application.CommandBars("cell")

Set MojeMenu = ContextMenu.Controls.Add(Type:=msoControlPopup, before:=1)

With MojeMenu
.Caption = "Asortyment"
For i = 0 To dane.Count - 1
With .Controls.Add(Type:=msoControlPopup, before:=1)
.Tag = "Poziom1"
.Caption = dane.keys()(i)
For j = 1 To dane.items()(i).Count
With .Controls.Add(Type:=msoControlButton, before:=1)
.Tag = "Poziom2"
.Caption = dane.items()(i)(j)
.OnAction = "'" & ThisWorkbook.Name & "'!" & "module1.dodawanie"
End With
Next
End With
Next

End With

End Sub

Private Sub InitializeMenuData()
Dim arr, i As Long, j As Long
Dim kat As String, c As Collection

Set dane = CreateObject("Scripting.Dictionary")

With ThisWorkbook.Sheets(1)
arr = .Range("C8:E" & .Cells(.Rows.Count, "C").End(xlUp).Row).Value
End With

For i = 1 To UBound(arr)
kat = arr(i, 2)
If Not dane.exists(kat) Then
Set c = New Collection
On Error Resume Next
For j = i To UBound(arr)
If arr(j, 2) = kat Then c.Add arr(j, 3), arr(j, 3)
Next
On Error GoTo 0
Set dane(kat) = c
End If
Next
End Sub

Sub dodawanie()
Dim nazwa As String
nazwa = Application.CommandBars.ActionControl.Caption

MsgBox "Wybrano " & nazwa
End Sub

kloszuu · Stały bywalec Excelforum **Pomógł:** 1 raz Posty: 253

Działa super dziękuje za pomoc, szkoda ze jest tylko możliwość dać jeden punkt za pomoc bo to chyba takie proste nie było do zrobienia. Wielki szacunek za wiedze.

Zakładam żeby dodać sortowanie do tego kod to nie będzie takie proste bo musiałbym sortować tablice kilku wymiarowa?

Pozdrawiam

Piotrek

Maciej Gonet · Wysłany: 05-10-2024, 21:11

Nie analizowałem kodu Tajana, bo myślałem nad swoim. Trochę dłużej mi zeszło.
Nie napisałeś nic o wersji Excela, więc nie wiedziałem co zrobić z sortowaniem.
Wybrałem wariant z arkuszem pomocniczym, do którego kopiuję dane i sortuję je metodą klasyczną, a następnie z powrotem do tablicy.

Kod:

Sub AddItemContextMenu()

' Czytaj dane i sortuj w arkuszu pomocniczym

Dim Dane
Dim wk1 As Worksheet, wk2 As Worksheet
Set wk1 = Worksheets("Przykllad")
Set wk2 = Worksheets("Pomoc")
Dane = wk1.Range("C7").CurrentRegion.Value
wk2.Range("A1").CurrentRegion.Clear
wk2.Range("A1").Resize(UBound(Dane), UBound(Dane, 2)).Value = Dane
wk2.Range("A1").CurrentRegion.Sort Key1:=wk2.Range("B1"), Order1:=xlDescending, _
Key2:=wk2.Range("C1"), Order2:=xlDescending, Header:=xlYes
Dane = wk2.Range("A1").CurrentRegion.Value

' utwórz polecenia

Dim ContextMenu As CommandBar
Dim MojeMenu As CommandBarControl

Application.CommandBars("Cell").Reset

Set ContextMenu = Application.CommandBars("cell")
Set MojeMenu = ContextMenu.Controls.Add(Type:=msoControlPopup, before:=1)
Dim i As Long, poziom As String
Dim Grupa As CommandBarPopup

With MojeMenu
.Caption = Dane(2, 1) ' "Asortyment"
For i = 2 To UBound(Dane)
If poziom <> Dane(i, 2) Then
Set Grupa = .Controls.Add(Type:=msoControlPopup, before:=1)
poziom = Dane(i, 2)
End If
With Grupa
.Tag = "Poziom1"
.Caption = poziom

With .Controls.Add(Type:=msoControlButton, before:=1)
.Tag = "Poziom2"
.Caption = Dane(i, 3)
.OnAction = "dodawanie" ' "'" & ThisWorkbook.Name & "'!" & "module1.dodawanie"
End With
End With
Next i
End With
End Sub

Sub dodawanie()
Dim nazwa As String
nazwa = Application.CommandBars.ActionControl.Caption

MsgBox "Wybrano " & nazwa
End Sub

Przyklad Menu.xlsm

Pobierz Plik ściągnięto 8 raz(y) 21.9 KB

kloszuu · Stały bywalec Excelforum **Pomógł:** 1 raz Posty: 253

Wersja Excel to będzie najnowsza bo używam Office 365 z najnowszymi uaktualnieniami.

Tez sie zastanawiałem nad ta opcja sortowana danych przed ich załadunkiem, przy moim poziomie programowania nawet osiągalna do wykonania, natomiast obawiam sie o szybkość działania przy użyciu operacji na arkuszu.

Mam pytanie a czy nie można do posortowania tego zakresu w czasie ladowania go do pamięci komputer, użyć wbudowanej formuły aplikacji Excel "Sort"?

Sadze ze tego typu operacje sortowania będzie szybsza w pamięci komputera niż jako operacja na pliku.

ple4 · Wysłany: 05-10-2024, 21:54

To jeszcze takie "cóś" do kolekcji:

Kod:

Option Explicit

Sub AddItemContextMenu()
Dim i As Long, j As Long, k As Long
Dim pn As String
Dim a, b, c

pn = "'" & ThisWorkbook.Name & "'!" & "Module1.dodawanie"

c = ThisWorkbook.ActiveSheet.Range("C7").CurrentRegion.Value
With CreateObject("System.Collections.ArrayList")
For i = 2 To UBound(c, 1)
If Not .Contains(c(i, 2)) Then .Add c(i, 2)
Next
.Sort: a = .ToArray: .Clear
For i = 2 To UBound(c, 1)
b = c(i, 2) & "," & c(i, 3)
If Not .Contains(b) Then .Add b
Next
.Sort: b = .ToArray: .Clear
End With
c = c(2, 1)

With Application.CommandBars("Cell")
.Reset
With .Controls.Add(Type:=msoControlPopup, Before:=1)
.Tag = "Poziom0"
.Caption = c
For i = 0 To UBound(a, 1)
With .Controls.Add(Type:=msoControlPopup, Before:=i + 1)
.Tag = "Poziom1"
.Caption = a(i)
For j = k To UBound(b, 1)
If b(j) Like a(i) & "*" Then
With .Controls.Add(Type:=msoControlButton)
.Tag = "Poziom2"
.Caption = StrConv(Split(b(j), ",", -1, 0)(1), vbProperCase)
.OnAction = pn
End With
k = k + 1
Else
Exit For
End If
Next
End With
Next
End With
.Controls(2).BeginGroup = True
End With

a = Empty: b = Empty
End Sub

kloszuu · Stały bywalec Excelforum **Pomógł:** 1 raz Posty: 253

wow ple4, super to chyba robi cala robote, dziekuje.

Wielki szacunek dla Was wszystich za wiedze i chec pomoc tym mnie zdolnym jak ja :-)

Pozdrawiam

Piotrek

ple4 · Wysłany: 05-10-2024, 22:16

kloszuu · Stały bywalec Excelforum **Pomógł:** 1 raz Posty: 253

@Ple4, mam tylko jedno pytanie do Twojego rozwiazania ten problem nie wystepowal w tych poprzednich propozycjach.

Mianowicie w momencie gdy na Poziomie 1 nie ma wpisanej kategorii tzn jest pozostawiona pusta komorka wowczas ten kod przestaje dzialac prawidlowo. Mozna jakos temu zaradzic, zeby traktowal puste pole jako kategorie i wrzucal tam wszystko bez konkretnie przypisanej kategorii?

Tajan · **Pomógł:** 5548 razy Posty: 12042

No, to jeszcze moja propozycja uzupełniona o sortowanie:

Kod:

Option Explicit

Dim dane As Object

Sub AddItemContextMenu()
Dim ContextMenu As CommandBar
Dim MojeMenu As CommandBarControl
Dim i As Long, j As Long
Dim c As Object
Dim poz1, poz2

InitializeMenuData

Application.CommandBars("Cell").Reset

Set ContextMenu = Application.CommandBars("cell")

Set MojeMenu = ContextMenu.Controls.Add(Type:=msoControlPopup, before:=1)

With MojeMenu
.Caption = "Asortyment"
poz1 = sortuj(dane.keys)
For i = 0 To UBound(poz1)
With .Controls.Add(Type:=msoControlPopup, before:=1)
.Tag = "Poziom1"
.Caption = poz1(i)
poz2 = dane(poz1(i))
For j = 0 To UBound(poz2)
With .Controls.Add(Type:=msoControlButton, before:=1)
.Tag = "Poziom2"
.Caption = poz2(j)
.OnAction = "'" & ThisWorkbook.Name & "'!" & "module1.dodawanie"
End With
Next
End With
Next

End With

End Sub

Private Sub InitializeMenuData()
Dim arr, i As Long, j As Long
Dim kat As String, c As Object

Set dane = CreateObject("Scripting.Dictionary")

With ThisWorkbook.Sheets(1)
arr = .Range("C8:E" & .Cells(.Rows.Count, "C").End(xlUp).Row).Value
End With

For i = 1 To UBound(arr)
kat = arr(i, 2)
If Not dane.exists(kat) Then
Set c = CreateObject("Scripting.Dictionary")
For j = i To UBound(arr)
If arr(j, 2) = kat Then c(arr(j, 3)) = arr(j, 3)
Next
dane(kat) = sortuj(c.keys)
End If
Next
End Sub

Private Function sortuj(tbl)
Dim el
With CreateObject("System.Collections.ArrayList")
For Each el In tbl
.Add el
Next
.Sort
.Reverse
sortuj = .toarray
End With
End Function

Sub dodawanie()
Dim nazwa As String
nazwa = Application.CommandBars.ActionControl.Caption

MsgBox "Wybrano " & nazwa
End Sub

ple4 · Wysłany: 06-10-2024, 00:18

kloszuu · Stały bywalec Excelforum **Pomógł:** 1 raz Posty: 253

Witam ple4,

Chyba bardziej szukalem taiego rozwiazania, troche przerobilem Twoje poniewaz ono wykluczalo artykul jezeli nie mial przypisanej kategorii na Poziomie1. Natomiast ja je klasywfikuje w odrebnej kategorii jako "BRAK"

Kod:

With CreateObject("System.Collections.ArrayList")
For i = 2 To UBound(c, 1)
If Len(Trim$(c(i, 2))) <> 0 Then
If Not .Contains(c(i, 2)) Then .Add c(i, 2)
Else
If Not .Contains(c(i, 2)) Then .Add "BRAK"
End If
Next
.Sort: a = .ToArray: .Clear
For i = 2 To UBound(c, 1)
If Len(Trim$(c(i, 2))) <> 0 Then
b = c(i, 2) & "," & c(i, 3)
If Not .Contains(b) Then .Add b
Else
b = "BRAK" & "," & c(i, 3)
If Not .Contains(b) Then .Add b
End If
Next
.Sort: b = .ToArray: .Clear
End With

Natomiast nie moge sobie poradzic zeby zmodyfikowac Twoj kod tak aby nie bral pod uwage wielosci liter. Moga pojawic sie sytuacje ze jedna osoba napisze "Pieczywo" a druga "pieczywo" to powinna byc nadal jedna kategoria natomiast Twoj kod traktuje je oddzielnie.

Czy mozn cos z tym zrobic?

Pozdrawiam

Piotrek

ple4 · Wysłany: 07-10-2024, 07:07