Excel Forum - Porady, Pomoc,  Excel Help, Excel FAQ Strona Główna
 FAQ  RegulaminRegulamin  Szukaj   Użytkownicy   Grupy   Rejestracja   Profil   Twoje wiadomości   Zaloguj 


Poprzedni temat «» Następny temat
ID tematu: 73230 Skopiuj do schowka Tworzenie tabeli (ListObjects) kodem VBA
Autor Wiadomość
Leon M 
Stały bywalec Excelforum


Wersja: Win Office 2016
Posty: 448
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 9 raz(y) 10.1 KB

ID posta: 419639 Skopiuj do schowka
 
 
Tadek 
Excel Expert


Wersja: Win Office 2010
Pomógł: 2144 razy
Posty: 5964
Wysłany: 13-08-2022, 06:58   

Trochę to niejasne.
Pokazałeś zakres, to pokaż jeszcze tę utworzoną tabelę.
ID posta: 419644 Skopiuj do schowka
 
 
sp3wbe 
Stały bywalec Excelforum


Wersja: Win Office 2016
Pomógł: 48 razy
Posty: 298
Wysłany: 13-08-2022, 08:12   

Leon
Wysłałem Tobie list na prywatną skrzynkę. Proszę o odpowiedź.
Pozdrawiam
_________________
Tadek
ID posta: 419646 Skopiuj do schowka
 
 
Leon M 
Stały bywalec Excelforum


Wersja: Win Office 2016
Posty: 448
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 11 raz(y) 12.32 KB

ID posta: 419653 Skopiuj do schowka
 
 
Marecki 
Excel Expert



Wersja: Win Office 2019
Pomógł: 2585 razy
Posty: 8602
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
_________________
Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.

Szkolenia z Excela , FB
Office 2019 Professional Plus , Windows 11 x64
Pozdrawiam, były mkkk23 teraz Marecki.
ID posta: 419660 Skopiuj do schowka
 
 
Leon M 
Stały bywalec Excelforum


Wersja: Win Office 2016
Posty: 448
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ę.
ID posta: 419661 Skopiuj do schowka
 
 
Marecki 
Excel Expert



Wersja: Win Office 2019
Pomógł: 2585 razy
Posty: 8602
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
_________________
Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.

Szkolenia z Excela , FB
Office 2019 Professional Plus , Windows 11 x64
Pozdrawiam, były mkkk23 teraz Marecki.
ID posta: 419662 Skopiuj do schowka
 
 
Leon M 
Stały bywalec Excelforum


Wersja: Win Office 2016
Posty: 448
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.
ID posta: 419663 Skopiuj do schowka
 
 
Marecki 
Excel Expert



Wersja: Win Office 2019
Pomógł: 2585 razy
Posty: 8602
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
_________________
Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.

Szkolenia z Excela , FB
Office 2019 Professional Plus , Windows 11 x64
Pozdrawiam, były mkkk23 teraz Marecki.
ID posta: 419664 Skopiuj do schowka
 
 
Leon M 
Stały bywalec Excelforum


Wersja: Win Office 2016
Posty: 448
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 5 raz(y) 21.67 KB

ID posta: 419670 Skopiuj do schowka
 
 
Tajan


Pomógł: 5091 razy
Posty: 11145
Wysłany: 14-08-2022, 14:56   

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
ID posta: 419671 Skopiuj do schowka
 
 
Leon M 
Stały bywalec Excelforum


Wersja: Win Office 2016
Posty: 448
Wysłany: 14-08-2022, 16:38   

Tajan, bardzo dziękuję.
ID posta: 419672 Skopiuj do schowka
 
 
Wyświetl posty z ostatnich:   
Odpowiedz do tematu
Nie możesz pisać nowych tematów
Nie możesz odpowiadać w tematach
Nie możesz zmieniać swoich postów
Nie możesz usuwać swoich postów
Nie możesz głosować w ankietach
Nie możesz załączać plików na tym forum
Możesz ściągać załączniki na tym forum
Dodaj temat do Ulubionych
Wersja do druku

Skocz do:  

Powered by phpBB modified by Przemo © 2003 phpBB Group
Theme xandgreen created by spleen& Programosy modified v0.3 by warna
Opieka techniczna www.wip.pl

Archiwum

Strona używa plików cookies.

Kliknij tutaj, żeby dowiedzieć się jaki jest cel używania cookies oraz jak zmienić ustawienia cookie w przeglądarce.
Korzystając ze strony użytkownik wyraża zgodę na używanie plików cookies, zgodnie z bieżącymi ustawieniami przeglądarki.
Sprawdź, w jaki sposób przetwarzamy dane osobowe