Elektroda.pl
Elektroda.pl
X
Proszę, dodaj wyjątek dla www.elektroda.pl do Adblock.
Dzięki temu, że oglądasz reklamy, wspierasz portal i użytkowników.

Excel - VBA - Dzielenie danych na arkusze wg. zmiennej.

29 Kwi 2010 22:12 16595 22
  • Poziom 9  
    Witam,
    mam problem ze stworzeniem makra, które ma za zadanie kopiowanie danych z arkusza1 bez powtórzeń po zmiennej np."A1" i wprowadzanie do nowego arkusza z nadaniem mu nazwy zmiennej filtrowanej "A1".
    Mam pewien kod programu, ale nie działa tak jak trzeba tzn. tworzy arkusz, ale nie nazywa go zmienną A1 oraz nie kopiuje danych z poprzedniego arkusza.

    Code:
    Sub Filtrowanie()
    
    Dim wbBook As Workbook
    Dim wsSheet As Worksheet
    Dim rnStart As Range
    Dim rnData As Range
    Dim i As Long

    Set wbBook = ThisWorkbook
    Set wsSheet = wbBook.Worksheets("Prowizja")

    With wsSheet
        Set rnStart = .Range("A1")
        Set rnData = .Range(.Range("A1"), .Cells(.Rows.Count, 3).End(xlUp))
    End With

    Application.ScreenUpdating = True

    For i = 1 To 5
        rnStart.AutoFilter Field:=1, Criteria1:= &ThisCust & i
        rnData.SpecialCells(xlCellTypeVisible).Copy
        Worksheets.Add before:=wsSheet
        ActiveSheet.Name = &ThisCust  & i
        Range("A1").PasteSpecial xlPasteValues
             
    Next i

    rnStart.AutoFilter Field:=1

    With Application
        .CutCopyMode = False
        .ScreenUpdating = False
    End With

    End Sub


    Może dodam tylko, że działam niestety na Excel2000.
    Z góry dziękuję za pomoc.

    Proszę pamiętać o używaniu znaczników code. - arnoldziq
    Poprawiłem tytuł. - arnoldziq
  • Poziom 40  
    Witam,
    A co to jest ThisCust?
    Moja uwaga: o ile nie jest to zamierzone, na końcu makra nie rób .screenUppdating = false, bo wtedy wyłączasz odświeżanie całego ekranu. Ja zawsze daję screenupdating=false na początku makra, a screenupdating=true na końcu - wtedy makro wykonuje się szybciej "w tle", nie odświeżając ekranu.
  • Poziom 9  
    Witam,
    dzięki za radę związaną z odświeżaniem ekranu, niestety bardzo kiepsko u mnie z pisaniem w VBA pod XLS ale potrzebuję makro dzielące dane na arkusze, a nigdzie nie znalazłam informacji o tworzeniu takiego kodu.
    W Thiscust - chodziło mi o odwołanie przy nadawaniu nazwy arkusza do danej po której zostały przefiltrowane dane i skopiowane do nowego arkusza.
  • Poziom 40  
    Przerobiłem trochę Twój kod, zamiast autofiltra używając funkcji .FIND.
    Kod poniżej, w razie wątpliwości - załącznik. Mam nadzieję że o to chodziło?
    pozdrawiam

    Code:
    Private Sub CommandButton1_Click()
    
    Dim wbBook As Workbook
    Dim wsSheet As Worksheet
    Dim rnStart As Range
    Dim rnData As Range
    Dim i As Long

    Application.ScreenUpdating = False

    On Error GoTo myErr

    Set wbBook = ThisWorkbook
    Set wsSheet = wbBook.Worksheets("Prowizja")

    With wsSheet
        Set rnData = .Range(.Range("A1"), .Cells(.Rows.Count, 1).End(xlUp)) 'zakres z danymi (z nagłowkiem)
        Set rnFiltr = .Range(.Range("A2"), .Cells(.Rows.Count, 1).End(xlUp))    'zakres do filtrowania
    End With

    'tworzymy tablicę o mask. pojemności = ilości wierszy danych
    Dim tabl() As String
    ReDim tabl(1 To rnData.Rows.Count)

    ile_w_tabl = 0
    'dla każdej komórki z zakresu danych
    For Each c In rnFiltr
        wiersz = 0
        dodaj = True
        'szukamy czy już nie filtrowaliśmy po tej wartości
        For i = 1 To ile_w_tabl
            If tabl(i) = c Then     'jeżeli tak - przechodzimy dalej
                dodaj = False
                Exit For
            End If
        Next i
       
        If dodaj = True Then
            'dodajemy kolejną komórkę do tablicy
            ile_w_tabl = ile_w_tabl + 1
            tabl(ile_w_tabl) = CStr(c)
               
            'tworzymy nowy arkusz
            wbBook.Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = c
               
            'filtrujemy po tej wartości: wyszukujemy kolejne w zakresie i kopiujemy je do nowego arkusza
            Dim iLoop As Integer
            Dim rCell As Range
            Set rCell = rnData(1, 1)    'pierwsza komórka do przeszukiwania
            ile_wyst = WorksheetFunction.CountIf(Columns(1), c)
           
            For iLoop = 1 To ile_wyst
                Set rCell = rnData.Columns(1).Find(What:=c, After:=rCell, _
                LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
                SearchDirection:=xlNext, MatchCase:=False)
                 
                 If Not rCell Is Nothing Then
                    wiersz = wiersz + 1
                    wsSheet.Range("A" & rCell.Row & ":C" & rCell.Row).Copy Destination:=wbBook.Sheets(CStr(c)).Range("A" & wiersz)
                 End If
            Next iLoop
        End If
    Next c

    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With

    MsgBox "Koniec", vbInformation + vbOKOnly, "OK"

    On Error GoTo 0

    Exit Sub
       
    myErr:
        Application.ScreenUpdating = True
        MsgBox "Błąd podczas działania makra", vbCritical + vbOKOnly, "Błąd"

    End Sub
  • Poziom 9  
    Witam,
    dziękuję bardzo, dzielenie na arkusze działa :D, tylko mam jakiś problem z kopiowaniem nagłówka. Dane przenoszą się do nowego arkusza, ale przy zapisywaniu pomijany jest nagłówek, pomimo że jak zauważyłam w kodzie jest kopiowany.
  • Pomocny post
    Poziom 40  
    Witam,
    Nagłówek nie jest kopiowany, jedynie dane.
    Najlepiej w kodzie po utworzeniu nowego arkusza przekopiuj go tak:
    Code:
    wsSheet.Range("A1:C1").Copy Destination:=wbBook.Sheets(CStr(c)).Range("A1")

    a żeby nie kopiować danych od pierwszego wiersza, zmień w kodzie wartość początkową zmiennej wiersz = 1
  • Poziom 9  
    Działa, dziękuję

    Dodano po 9 [minuty]:

    Mam jeszcze jedno pytanie do dzielenia danych. Czy można taki plik przekształcić, aby najpierw wg kryterium 1 dzielił plik na arkusze (to już jest), a następnie wg kryterium 2 nowo powstałe arkusze kopiował do nowego utworzonego pliku w zależności od informacji w kolumny B(zawsze jedna wartość dla danego arkusza). Np. arkusz1, arkusz3 posiadają w kolumnie B=zima; arkusz2, arkusz4 kolumna=lato. W tym przypadku tworzymy plik lato z zawartością arkusz2 i 4 oraz zima z zawartością arkusz1 i 3.

    Oczywiście system tworzenia plików i arkuszy może być inny.

    I jeszcze jedno pytanie, jak można w kodzie dodać formatowanie nagłówka i stopki przy tworzeniu nowego pliku lub arkusza?

    Dziękuję za informację. Wiem, że szukam odp. na dużo pytań ale stworzenie takich plików usprawni mi bardzo pracę.
  • Poziom 40  
    Hej, podejrzyj kod w załączniku :)
    Najpierw dzieli on dane na zakładki, a potem kopiuje je do plików.
    Formatowanie nagłówka i stopki jest proste - wystarczy że zarejestrujesz makro ustawiając sobie nagłówek i stopkę, a potem zmodyfikujesz powstały kod wg własnych potrzeb. Z tą różnicą że zamiast fragmentu:
    Code:
    With ActiveSheet.PageSetup [...]

    wstawiasz którego worksheetu w którym workbooku ma dotyczyć, np.
    Code:
    With wbNowy.Worksheets(1).PageSetup [...]
  • Poziom 9  
    Jeszcze raz dzięki, co do nagłówka już sobie poradziłam (poniżej kod - dla zainteresowanych).

    Code:
    Private Sub Dzielenie_Click()
    

    Dim wbBook As Workbook
    Dim wsSheet As Worksheet
    Dim rnStart As Range
    Dim rnData As Range
    Dim i As Long

    Application.ScreenUpdating = False

    On Error GoTo myErr

    Set wbBook = ThisWorkbook
    Set wsSheet = wbBook.Worksheets("Prowizja")

    With wsSheet
        Set rnData = .Range(.Range("A1"), .Cells(.Rows.Count, 1).End(xlUp)) 'zakres z danymi (z nagłowkiem)
        Set rnFiltr = .Range(.Range("A2"), .Cells(.Rows.Count, 1).End(xlUp))    'zakres do filtrowania
    End With

    'tworzymy tablicę o mask. pojemności = ilości wierszy danych
    Dim tabl() As String
    ReDim tabl(1 To rnData.Rows.Count)

    ile_w_tabl = 0
    'dla każdej komórki z zakresu danych
    For Each d In rnFiltr
        wiersz = 1 ' od którego wiersza zaczynamy wyświetlać dane
        dodaj = True
        'szukamy czy już nie filtrowaliśmy po tej wartości
        For i = 1 To ile_w_tabl
            If tabl(i) = d Then     'jeżeli tak - przechodzimy dalej
                dodaj = False
                Exit For
            End If
        Next i
       
        If dodaj = True Then
            'dodajemy kolejną komórkę do tablicy
            ile_w_tabl = ile_w_tabl + 1
            tabl(ile_w_tabl) = CStr(d)
               
            'tworzymy nowy arkusz
            wbBook.Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = d
            Set wsNowy = wbBook.Worksheets(CStr(d))
            'nadanie nagłówka oraz ustawień strony
                With ActiveSheet.PageSetup
                    .PrintTitleRows = ""
                    .PrintTitleColumns = ""
                End With
                ActiveSheet.PageSetup.PrintArea = ""
                With ActiveSheet.PageSetup
                    .LeftHeader = "&""Arial Baltic,Normalny""&8Nazwa jakaś" & Chr(10) & "tekst nowa linijka" & Chr(10) & "jeszcze jedna linijka"
                    .CenterHeader = "&""Arial Baltic,Pogrubiony""&10Zestawienie dla mnie " & CStr(d)
                    .RightHeader = "&D"
                    .LeftFooter = ""
                    .CenterFooter = ""
                    .RightFooter = ""
                    .LeftMargin = Application.InchesToPoints(0.433070866141732)
                    .RightMargin = Application.InchesToPoints(0.196850393700787)
                    .TopMargin = Application.InchesToPoints(1.18110236220472)
                    .BottomMargin = Application.InchesToPoints(0.78740157480315)
                    .HeaderMargin = Application.InchesToPoints(0.511811023622047)
                    .FooterMargin = Application.InchesToPoints(0.511811023622047)
                    .PrintHeadings = False
                    .PrintGridlines = False
                    .PrintComments = xlPrintNoComments
                    .PrintQuality = 600
                    .CenterHorizontally = True
                    .CenterVertically = False
                    .Orientation = xlLandscape
                    .Draft = False
                    .PaperSize = xlPaperA4
                    .FirstPageNumber = xlAutomatic
                    .Order = xlDownThenOver
                    .BlackAndWhite = False
                    .Zoom = 100
                End With
               
            'nadawanie nagłówka
            'wbBook.Sheets(CStr(d)).Range("A1").Value = "Zestawienie prowizyjne dla Oddziału "
            'wbBook.Sheets(CStr(d)).Range("A1").Font.Size = 14
            'wbBook.Sheets(CStr(d)).Range("A1").Font.Bold = True
            'kopiowanie nagłówka do nowego arkusza, A2- określa początek wyświetlania danych
            wsSheet.Range("A1:O1").Copy Destination:=wbBook.Sheets(CStr(d)).Range("A1")
         
            'filtrujemy po tej wartości: wyszukujemy kolejne w zakresie i kopiujemy je do nowego arkusza
            Dim iLoop As Integer
            Dim rCell As Range
            Set rCell = rnData(1, 1)    'pierwsza komórka do przeszukiwania
            ile_wyst = WorksheetFunction.CountIf(Columns(1), d)
           
            For iLoop = 1 To ile_wyst
                Set rCell = rnData.Columns(1).Find(What:=d, After:=rCell, _
                LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
                SearchDirection:=xlNext, MatchCase:=False)
                 
                 If Not rCell Is Nothing Then
                    wiersz = wiersz + 1
                    'kopiowanie danych do nowego arkusza dla danego zakresu
                    wsSheet.Range("A" & rCell.Row & ":O" & rCell.Row).Copy Destination:=wbBook.Sheets(CStr(d)).Range("A" & wiersz)
                   
                 End If
                   
            Next iLoop
        End If
       
    Next d

    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With

    MsgBox "Koniec", vbInformation + vbOKOnly, "OK"

    On Error GoTo 0

    Exit Sub
       
    myErr:
        Application.ScreenUpdating = True
        MsgBox "Błąd podczas działania makra", vbCritical + vbOKOnly, "Błąd"

    End Sub

    Dodano po 39 [minuty]:

    [Marcinj12] Sprawdziłam zamieszczone przez Ciebie makro, i niestety przy podaniu nowych zmiennych do filtrowania pojawia się komunikat o błędzie, następującej treści:
    "Błąd podczas działania makra. Nie można nadać arkuszowi nazwy, którą posiada już inny arkusz, obiekt biblioteki lub skoroszyt, do którego występuje odwołanie w VBA".

    Niestety nie wiem, dlaczego pojawia się komunikat, skoro nie ma innych plików o takiej nazwie otwartych, a dane zostały zmienione na nowe nazwy analogicznie do wcześniejszego zapisu.

    Jedyna zmiana jaką dokonałam, to dodanie miejsca docelowego zapisu plików, co przy Twoich danych działało:

    wbNowy.SaveAs Filename:="D:\Moje Dokumenty\Excel\test\Pliki\" & druga_kolumna & ".xls"

    Dodano po 8 [minuty]:

    Plik po zmianie danych w załączeniu. I przy okazji pytanie jak dynamicznie dodać podsumowanie w tym makro kolumny ?

    Proszę pamiętać o używaniu znaczników code. - arnoldziq
  • Poziom 40  
    To dlatego że trochę zamieszałeś z opisem ;) Pisałeś o podziale według dwóch kolumn A i B - przy takim założeniu musiały by to być niepowtarzające się pary.

    Póki co linijkę:
    Code:
    If tabl(i, 1) = c And tabl(i, 2) = druga_kolumna Then

    zamień na:
    Code:
    If tabl(i, 1) = c Then

    i powiedz czy to jest to, o co Ci chodzi?

    Jeżeli chodzi o dynamiczna podsumowanie kolumny, to możesz np. użyć funkcji.
    W dowolnym momencie, np. przed zapisaniem nowego arkusza, wstaw taki kod:

    Code:
    ost_wiersz = wsSheet.Range("B65536").End(xlUp).Row   'ustala ostatni wypełniony  wiersz w kolumnie B arkusza wsSheet
    

    wsSheet.Cells(ost_wiersz + 1, 2).Formula = "=SUM(B2:B" & ost_wiersz & ")"   'wstawia funkcję SUMA(B2:Bxxx)


    PS. Pamiętaj że odpalając makro nie możesz mieć w pliku utworzonych żadnych zakładek. Program tworzy je sam. Można to oczywiście zmodyfikować, np. tak zastęując fragment tworzący arkusz:

    Code:
     'tworzymy nowy arkusz
    
            jest_zakl = False
            For Each ws In wbBook.Worksheets
                If ws.Name = c Then
                    jest_zakl = True
                    Exit For
                End If
            Next ws
           
            If Not jest_zakl Then
                wbBook.Sheets.Add(After:=wbBook.Worksheets(wbBook.Worksheets.Count)).Name = c
            Else
                wbBook.Sheets(CStr(c)).Range("A1:IV65536").ClearContents    'czyści zawartość
            End If
  • Poziom 9  
    Ok, sprawdzę jutro, dzisiaj niestety nie mam możliwości zobaczenia, ponieważ na tym kompie mam jakiś Microsoft Works :(
    Ale jeszcze jedno pytanie, troszkę sobie chciałam zmodyfikować Twoje makro aby można było pobierać dane wejściowe z pliku zewnętrznego i utknęłam przy kopiowaniu określonego zakresu do nowo stworzonego arkusza, tzn. nagłówek, formatowanie stopki i nadawanie nazwy działa, nie działa przekopiowanie samych danych.
    Aby czytać dane z pliku zewnętrznego dodałam następujące linijki kodu:
    1. Aktywowanie pliku z dodaniem ścieżki zapisu zmodyfikowanych danych
    Code:
    Private Sub CommandButton1_Click()
    


    plik = Dir(ActiveWorkbook.Path + "\pliki\*.xls")

    .....

    Application.ScreenUpdating = False

    On Error GoTo myErr

    Set wbBook = Workbooks.Open(ActiveWorkbook.Path + "\pliki\" + plik)
    wbBook.Activate
    Set wsSheet = wbBook.Worksheets("Prowizja")


    2. Zamknięcie oraz zapisanie modyfikowanego pliku

    Code:
     wbBook.SaveAs
    
    wbBook.Close
  • Poziom 40  
    Ten fragment kodu jest poprawny i u mnie działa. Upewnij się że katalog pliki jest na tym samym poziomie co plik który odpalasz i są w nim pliki .xls
  • Poziom 9  
    Sprawdziłam Twoją modyfikację, niestety nie do końca działa to tak jak bym chciała, tzn. dane są dzielone po 1 zmiennej i zapisywane w nowym pliku, ale w nowym pliku już po zapisaniu nie zostały podzielone po 2 zmiennej na arkusze. Zapis po zmianie podanej przez Ciebie działa ale dla danych lato, zima (dla miejscowości nie).
  • Poziom 40  
    A możesz wrzucić jakiś plik z przykładowymi danymi i przykład jakby to miało wyglądać po podziale?
  • Pomocny post
    Poziom 40  
    OK, przykład dużo wyjaśnia :)
    Możesz to zrobić np. tak jak w załączniku. Program działa na pliku-źródle w katalogu "pliki" a wyniki zapisuje na c:\
    Spróbuj dostosować do swoich potrzeb.
  • Poziom 9  
    Super, dziękuję bardzo za pomoc - pliczek działa.
    Na koniec jeszcze mam tylko jedno pytanie, bo wstawiam sobie formatowanie nagłówka do kodu i mam problem z umieszczeniem go w odpowiednim miejscu, tak aby pojawiał się na wszystkich zakładkach w nowo utworzonych plikach tzn. kopiuje mi ale tylko do pierwszej zakładki w nowym pliku :(
  • Poziom 40  
    Odszukaj w kodzie taki fragment:
    Code:
    'jeżeli nie istnieje utwórz zakładkę o nazwie kolumny B
    
        If Not jest_zakl Then
            wbNowy.Sheets.Add(After:=wbNowy.Worksheets(wbNowy.Worksheets.Count)).name = nazwa_zakladki
           
            Set wsNowy = wbNowy.Sheets(nazwa_zakladki)
            wiersz = 1
           
            'kopiowanie nagłówka
            wsZrodlo.Range("A1:C1").Copy Destination:=wsNowy.Range("A" & wiersz)

           '-----xxxxx tu wstaw kod xxxxxx-------
        Else
            Set wsNowy = wbNowy.Sheets(nazwa_zakladki)
            wiersz = wsNowy.Range("B65536").End(xlUp).Row
        End If


    W miejscu oznaczonym xxx możesz wstawić akcje, które działają na nowotworzonej zakładce: wsNowy
    Jeżeli chcesz przypisać nagłówek i stopkę wydruku, nagraj makro, zmień w nim wszystkie wystąpienia ActiveSheet (pewnie tego nie zrobiłeś?) na wsNowy i wstaw tam.
    Np.
    Code:
    With wsNowy.PageSetup
    
                .LeftHeader = "&D"
                .CenterHeader = "Zestawienie"
                .RightHeader = ""
                .LeftFooter = ""
                .CenterFooter = "Strona &P"
                .RightFooter = ""
                .LeftMargin = Application.InchesToPoints(0.787401575)
                .RightMargin = Application.InchesToPoints(0.787401575)
                .TopMargin = Application.InchesToPoints(0.984251969)
                .BottomMargin = Application.InchesToPoints(0.984251969)
                .HeaderMargin = Application.InchesToPoints(0.5)
                .FooterMargin = Application.InchesToPoints(0.5)
                .PrintHeadings = False
                .PrintGridlines = False
                .PrintComments = xlPrintNoComments
                '.PrintQuality = 600  to lepiej usunąć
                .CenterHorizontally = False
                .CenterVertically = False
                .Orientation = xlPortrait
                .Draft = False
                .PaperSize = xlPaperA4
                .FirstPageNumber = xlAutomatic
                .Order = xlDownThenOver
                .BlackAndWhite = False
                .Zoom = 100
                .PrintErrors = xlPrintErrorsDisplayed
            End With
  • Poziom 9  
    Dzięki,
    właśnie do tego dotarłam ale inną metodą, przed skopiowaniem nagranego makra tworzącego nagłówek wpisałam, po sumowaniu komórek:
    Code:
    'suma kolumny G
    
        ost_wiersz = wsNowy.Range("E65536").End(xlUp).Row
                 
        With wsNowy.Cells(ost_wiersz + 1, 5)
            .Font.Bold = True
            .Formula = "=SUM(E2:E" & ost_wiersz & ")"
        End With
     
      Set wsNowy = ActiveSheet
     


    Ale dzięki za info. oraz pomoc, a właściwie wyręczeniu w tworzeniu kodu :):D
  • Poziom 1  
    Witam,

    mam takie banalne pytanie.

    W czasie działania makra, program wybiera pewne liczby (numery projektów) Zakładają się arkusze o nazwach będących numerami tych projektów, np :
    127, 116 , 214..

    Program kontynuuje pracę i chce zapisac wyniki do arkusza o numerze odpowiedniego projektu. Próbuję posłużyć się tablicą zmiennych, która zawiera numery znalezionych projektów:

    projekt (ii).Cells(2, 2) = "Dane do projektu " & ii

    to jednak nie chce działać, z powodu nie wlasciwego typu zmiennej.

    Nie mogę posłużyć się zdefiniowaniem numerów projektów jako zmienna "worksheet", bo na początku programu numery arkuszy nie są znane.
  • Poziom 2  
    Witam,

    Troszkę odgrzebię temat.
    Mam pewien problem, ponieważ dostosowałem podany przez Was kod do swoich potrzeb (de facto zmiana kolumny sortowania), ale... nie działa do końca tak jak powinien. Kod powinien dodawać do nowego arkusza tylko wiersze z danej grupy, czyli w tym przypadku jeżeli mamy "A" to wiersze z tej grupy. "A" w tym przypadku znajduje że występuje 12 razy, ale kopiuje od pierwszego wiersza dwanaście razy. Tak samo w przypadku innych grup. Znajduje ilość, ale znowu kopiuje je od pierwszego wiersza do ilości znalezionych, a nie konkretne wiersze.

    Załączam załącznik, abyście mogli sami lepiej zobrazować sytuację.

    Byłbym wdzięczny za pomoc w poprawieniu makra i naprowadzenie, gdzie jest błąd.
  • Poziom 40  
    Witam,
    Myślę że po dwóch latach trochę bym inaczej ten kod dzisiaj napisał (czytaj: uprościł), mianowicie:
    Kod: vb
    Zaloguj się, aby zobaczyć kod


    A Twój kod z załącznika nie działa, gdyż we fragmencie:
    Kod: vb
    Zaloguj się, aby zobaczyć kod
    masz znikąd wziętą zmienną n, domyślnie równą Nothing.
  • Poziom 2  
    Nie wiem dlaczego pojawiło się to "n", ale mniejsza o to.

    Wszystko bardzo ładnie działa! Dostosowałem tylko, aby nie kopiował formuł, które zostały dodane, a same wyliczone wartości.

    Jeszcze raz bardzo dziękuję!