Excel Forum - Porady, Pomoc, Excel Help, Excel FAQ - Tworzenie tabeli (ListObjects) kodem VBA

Leon M · Wysłany: 12-08-2022, 21:30 **Tworzenie tabeli (ListObjects) kodem VBA**

Szanowni Forumowicze,

Zwracam się do Was z prośbą o przedstawienie, jak za pomocą VBA można utworzyć tabelę i osadzić ją na określonym zakresie arkusza, który też będzie stanowił źródło danych dla tworzonej tabeli. Kolejne założenia są takie, że tabela będzie zawierać nagłówki kolumn jak w zakresie oraz wiersz sumy.
w załączniku zamieszczam plik z przykładowym zakresem w arkuszu.

Za odpowiedzi z góry bardzo dziękuję.

Tabela.xlsm

Pobierz Plik ściągnięto 29 raz(y) 10.1 KB

Tadek · Wysłany: 13-08-2022, 06:58

Trochę to niejasne.
Pokazałeś zakres, to pokaż jeszcze tę utworzoną tabelę.

sp3wbe · Wysłany: 13-08-2022, 08:12

Leon
Wysłałem Tobie list na prywatną skrzynkę. Proszę o odpowiedź.
Pozdrawiam

Leon M · Wysłany: 13-08-2022, 10:49

sp3wbe, wysłałem odpowiedź na Twoją prywatną wiadomość.

Tadek, dziękuję za zainteresowanie tematem.

W załączniku zamieszczam plik, w którym pokazałem w arkuszu 2 wygląd tabeli po jej osadzeniu na zakresie w arkuszu 1.

Tabela 2.xlsm

Pobierz Plik ściągnięto 32 raz(y) 12.32 KB

Marecki · Wysłany: 13-08-2022, 19:32

Zobacz tak:

Kod:

Sub Test()
Dim Rng As Range
Dim LastR As Long
Dim LastC As Long
Dim el As Object

With Sheets("Arkusz1")
LastR = .Cells(.Rows.Count, 5).End(xlUp).Row - 3
LastC = .Cells(3, .Columns.Count).End(xlToLeft).Column - 4
Set Rng = .Range("E3").Resize(LastR, LastC)
End With

With Sheets("Arkusz2")
.Range("E3").Resize(LastR + 1, LastC).Delete
.Range("E3").Resize(LastR, LastC).Value = Rng.Value
.ListObjects.Add(xlSrcRange, .Range("E3").Resize(LastR, LastC), , xlYes).Name = "Tabela"

With .ListObjects("Tabela")
.ShowAutoFilter = False
.ShowTotals = True
For Each el In .ListColumns
If el.Index > 1 Then
.ListColumns(el.Name).TotalsCalculation = xlTotalsCalculationSum
End If
Next el
End With
End With

Set Rng = Nothing

End Sub

Leon M · Wysłany: 13-08-2022, 20:54

Marecki, bardzo dziękuję za odpowiedź.

Kod, owszem tworzy tabelę, ale nie do końca wedle mojego zamysłu. :-)

Chciałem, aby makro utworzyło tabelę na zakresie E3:H13 w arkuszu 1.
W arkuszu 2 tylko pokazałem, jak zasugerował Tadek, jak miałaby wyglądać ta tabela w arkuszu 1.
Zatem kieruję prośbę o modyfikacje kodu do przedstawionych założeń, za co z góry bardzo dziękuję.

Marecki · Wysłany: 13-08-2022, 21:29

O to chodzi ?

Kod:

Sub Test()
Dim LastR As Long
Dim el As Object

With Sheets("Arkusz1")
LastR = .Cells(.Rows.Count, 5).End(xlUp).Row
If VBA.LCase$(.Cells(LastR, 5).Value) = "suma" Then .Rows(LastR).Delete
.ListObjects.Add(xlSrcRange, .Range("E3").CurrentRegion, , xlYes).Name = "Tabela"

With .ListObjects("Tabela")
.ShowAutoFilter = False
.ShowTotals = True
For Each el In .ListColumns
If el.Index > 1 Then
.ListColumns(el.Name).TotalsCalculation = xlTotalsCalculationSum
End If
Next el
End With
End With

End Sub

Leon M · Wysłany: 13-08-2022, 22:36

Marecki, dziękuję bardzo za modyfikację kodu. O to właśnie chodziło. :-)

Chciałbym jeszcze zapytać, jak usunąć tę tabelę, tj. jak konwertować na zwykły zakres, też przy pomocy Vba.

Marecki · Wysłany: 13-08-2022, 22:52

Proszę:

Kod:

Sub Test1()
Dim Rng As Range

On Error Resume Next
With Sheets("Arkusz1").ListObjects("Tabela")
Set Rng = .Range
.Unlist
End With

With Rng
.Interior.ColorIndex = xlColorIndexNone
.Font.ColorIndex = xlColorIndexAutomatic
.Borders.LineStyle = xlLineStyleNone
.Font.Bold = False
End With
On Error GoTo 0

Set Rng = Nothing

End Sub

Leon M · Wysłany: 14-08-2022, 13:51

Marecki, bardzo dziękuję za kod usuwający tabelę.

Chciałbym jeszcze dopytać w kwestii funkcjonowania kodu.

Przy pierwszym wywołaniu procedury tworzącej tabelę znaki w wierszu nagłówkowym przyjmują kolor biały, natomiast po usunięciu tabeli i ponownym jej utworzeniu znaki w wierszu nagłówkowym przybierają już kolor czarny. Przy manualnej zmianie stylu tabeli na taki, w którym czcionka w wierszu nagłówkowym jest w kolorze białym (np. średni3), kolor czcionki w wierszu nagłówkowym utworzonej tabeli pozostaje nadal w kolorze czarnym.

Podjąłem próbę nadania tabeli określonego stylu już na etapie jej tworzenia w VBA.
W tym celu w metodzie Add dodałem parametr TableStyleName, ale i przy tym sposobie pojawia się ten sam, co powyżej opisany, problem.

Nie wiem, jak uporać się z tą kwestią, dlatego też proszę bardzo o pomoc, za co z góry dziękuję.

Tabela 3 - tworzenie i usuwanie tabeli kodem VBA.xlsm

Pobierz Plik ściągnięto 26 raz(y) 21.67 KB

Tajan · **Pomógł:** 5376 razy Posty: 11725

Przed usunięciem tabeli usuń styl, który zastosowałeś::

Kod:

.TableStyle = ""

Dzięki temu do usunięcia tabeli wystarczy taki kod:

Kod:

Sub UsunTabele()
With Sheets("Arkusz1").ListObjects("Tabela")
.TableStyle = ""
.Unlist
End With
End Sub

Leon M · Wysłany: 14-08-2022, 16:38

Tajan, bardzo dziękuję.