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
Przesunięty przez: Artik
17-12-2018, 17:01
filtrowanie i przenoszenie do nowej zakładki
Autor Wiadomość
malya 
Fan Excela


Posty: 82
Wysłany: 17-12-2018, 15:56   filtrowanie i przenoszenie do nowej zakładki

Witam,
Potrzebuję makro, które będzie przenosiło/grupowało dane filtrując po wartościach pierwszej kolumny i zapisywało je każde w osobnej zakładce, a zakładka otrzyma nazwę jak wartości tych danych.

Czyli najpierw filtruje dane po wartości pierwszej kolumny np wartość 300, przenoszę je do nowej zakładki i zakładkę nazywam 300. Tak do wyczerpania wszystkich wartości. Dane powinny się kopiować bez nagłówka

Przykład danych w załączniku

przy_01.xlsx
Pobierz Plik ściągnięto 15 raz(y) 16.06 KB

ID posta: 358595 Skopiuj do schowka
 
 
umiejead 
Excel Expert


Pomógł: 228 razy
Posty: 1233
Wysłany: 17-12-2018, 17:24   

W Arkusz1:
Kod:
Option Explicit

Private Sub CommandButton1_Click()
Dim ws As Worksheet, nws As Worksheet, tws As Worksheet, k As Integer
Dim i As Integer, j As Integer, d As Integer, n As String, t As Double

On Error Resume Next

Set tws = Sheets("Arkusz1")
t = Now
Application.ScreenUpdating = False

Application.DisplayAlerts = False
For Each ws In ThisWorkbook.Sheets
    If ws.Name <> tws.Name Then ws.Delete
Next ws
Application.DisplayAlerts = True

d = Cells(Rows.Count, "A").End(xlUp).Row
j = 1
k = 0

For i = 2 To d
    If tws.Cells(i, 1).Value <> tws.Cells(i - 1, 1).Value _
        And tws.Cells(i, 1).Value <> "" Then
        With ThisWorkbook
            n = CInt(Cells(i, 1).Value)
            Set nws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
            nws.Name = n
            k = k + 1
        End With
        j = 1
    End If
    tws.Cells(i, 1).EntireRow.Copy Destination:=nws.Cells(j, 1)
    j = j + 1
Next i

tws.Activate
tws.Range("A1").Select
Application.ScreenUpdating = True

MsgBox "Wykonano!" & vbCrLf & vbCrLf & "Wierszy: " & i - 2 & vbCrLf & _
    "Arkuszy: " & k & vbCrLf & "Czas: " & Format(Now - t, "nn:ss") & " sek.", _
    vbInformation, "INFO"

End Sub

Uwagi:
1. Założyłem że dane są posortowane po "C_FRS". Jeśli nie - kod zwróci fałszywe wyniki albo się rozsypie.
2. Makro na początek usuwa wszystkie arkusze oprócz "Arkusz1". Nazwa jest zaszyta w kodzie.
.

Kopia przy_01.xlsm
Pobierz Plik ściągnięto 7 raz(y) 39.63 KB

_________________
.
Jak poprawnie opisać problem: http://www.excelforum.pl/...ika-vt59262.htm
I dbajmy - proszę - o poprawną polszczyznę.
ID posta: 358597 Skopiuj do schowka
 
 
nunus67 
ExcelSpec


Pomógł: 167 razy
Posty: 489
Wysłany: 17-12-2018, 17:42   

umiejead był szybszy i zamieścił swoje rozwiązanie w czasie gdy ja przeglądałem pliki w komputerze w poszukiwaniu makra do sortowania arkuszy po nazwie.
Jednak ponieważ coś tam jednak zrobiłem zamieszczam również swoje wypociny.
Zajrzyj do pliku.

przy_01 n67.xlsm
Pobierz Plik ściągnięto 8 raz(y) 31.03 KB

_________________
Nunus67
ID posta: 358599 Skopiuj do schowka
 
 
umiejead 
Excel Expert


Pomógł: 228 razy
Posty: 1233
Wysłany: 17-12-2018, 19:28   

Dorzuciłem sortowanie (po C_FRS a następnie po C_ITM8).
.

Kopia przy_01.xlsm
Pobierz Plik ściągnięto 10 raz(y) 39.36 KB

_________________
.
Jak poprawnie opisać problem: http://www.excelforum.pl/...ika-vt59262.htm
I dbajmy - proszę - o poprawną polszczyznę.
Ostatnio zmieniony przez umiejead 17-12-2018, 20:45, w całości zmieniany 1 raz  
ID posta: 358608 Skopiuj do schowka
 
 
ąćęłńóś
ExcelSpec


Pomógł: 158 razy
Posty: 721
Wysłany: 17-12-2018, 20:35   

malya napisał/a:
... filtruje dane po wartości pierwszej kolumny np wartość 300 ...
A ja się zapytuję, czy cyferki w kolumnie "A" zawsze będą miały zera-wiodące, czy też nie utrzymają schematu i pojawią się zupełnie inne wartości. Skąd pytanie ?
Z powodu działania Autofiltra, który, będąc najprostszym rozwiązaniem w tej sytuacji, ma jednak pewne fochy ...
ID posta: 358609 Skopiuj do schowka
 
 
malya 
Fan Excela


Posty: 82
Wysłany: 17-12-2018, 20:47   

ąćęłńóś, niestety zera mogą być, a nie muszą, jeżeli dane pochodzą prosto z serwera, to będą, ale jak raport już toś obrabiał, to bardzo często kolumna jest już konwertowana na liczbowe i zer nie będzie. Jutro przetestuje rozwiązania.
ID posta: 358610 Skopiuj do schowka
 
 
ąćęłńóś
ExcelSpec


Pomógł: 158 razy
Posty: 721
Wysłany: 17-12-2018, 22:16   

1. Czy to znaczy, że i w jednej kolumnie także może być zarówno 00375, jak i 375 ?
2. Czy te "00" są zbędne, czy lepiej żeby były ?
ID posta: 358617 Skopiuj do schowka
 
 
malya 
Fan Excela


Posty: 82
Wysłany: 17-12-2018, 22:32   

ąćęłńóś napisał/a:
1. Czy to znaczy, że i w jednej kolumnie także może być zarówno 00375, jak i 375 ?

teoretycznie tak, ale to oczywiście będzie błąd, który do tej pory był ręcznie modyfikowany.
Cytat:
2. Czy te "00" są zbędne, czy lepiej żeby były ?

są zbędne, można całą kolumnę przerobić na liczbowe, taki format jest bardziej pożądany
ID posta: 358618 Skopiuj do schowka
 
 
ąćęłńóś
ExcelSpec


Pomógł: 158 razy
Posty: 721
Wysłany: 17-12-2018, 22:59   

Sprawdź:

Module1.bas.txt
Pobierz Plik ściągnięto 13 raz(y) 2.98 KB

ID posta: 358621 Skopiuj do schowka
 
 
kuma 
Excel Expert


Pomógł: 1125 razy
Posty: 3382
Wysłany: 17-12-2018, 23:29   

U mnie filtrowanie trochę inaczej
Kod:
Sub UnikatyDoArkuszy()
    Dim rng As Range
    Dim a(), k, v
    Dim sh As Worksheet
    Dim d As Object
    Dim i As Integer, md As Integer
   
    Application.ScreenUpdating = False
    Set d = CreateObject("scripting.dictionary")
   
    Sheets("Arkusz1").Activate
    Set rng = ActiveSheet.[A1].CurrentRegion
    rng.Sort Columns(1), xlAscending, , , , , , xlYes
   
    If IsArray(rng.Value) Then
        a = rng.Value
        With d
            For i = 2 To UBound(a)
                md = CDbl(a(i, 1))
                If Not .exists(md) Then
                    d(md) = i
''                    d(md) = "1," & i          'gdyby miały być nagłówki
                Else
                    d(md) = d(md) & "," & i
                End If
            Next
        End With
        On Error Resume Next
        For Each k In d.keys
            v = Split(d(k), ",")
            Set rng = Worksheets(CStr(k)).[A1]
            If Err.Number = 0 Then
                With Worksheets(CStr(k))
                    .UsedRange.ClearContents
                    .[A1].Resize(UBound(v) + 1, UBound(a, 2)) = _
                            Application.Index(a, Application.Transpose(v), Array(1, 2))
                End With
            Else
                With ThisWorkbook
                    .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = CStr(k)
                    ActiveSheet.[A1].Resize(UBound(v) + 1, UBound(a, 2)) = _
                            Application.Index(a, Application.Transpose(v), Array(1, 2))
                End With
                Err.Clear
            End If
        Next
    End If
    Sheets("Arkusz1").Activate
    Set d = Nothing
    Set rng = Nothing
End Sub
Pozdrawiam.
ID posta: 358626 Skopiuj do schowka
 
 
umiejead 
Excel Expert


Pomógł: 228 razy
Posty: 1233
Wysłany: 18-12-2018, 03:17   

Porównanie kodów (dla zwiększenia miarodajności ustawiłem ilość wierszy na 2000):
1. umiejead: bardzo wolny / poprawne wyniki.
2. ąćęłńóś: szybki* / poprawne wyniki.
3. kuma: najszybszy / niepoprawne wyniki.**

The winner is:................... ąćęłńóś. :clap :clap :clap


*nie licząc czasu na potwierdzanie pytań. BTW: Zdanie kończymy kropką lub innym znakiem interpunkcyjnym typu "znak końca zdania". :mrgreen:
*kod nie sortuje danych / nie usuwa "śmieciowych" arkuszy.

Kopia przy_01.xlsm
Pobierz Plik ściągnięto 5 raz(y) 137.81 KB

_________________
.
Jak poprawnie opisać problem: http://www.excelforum.pl/...ika-vt59262.htm
I dbajmy - proszę - o poprawną polszczyznę.
Ostatnio zmieniony przez umiejead 18-12-2018, 17:09, w całości zmieniany 1 raz  
ID posta: 358639 Skopiuj do schowka
 
 
ąćęłńóś
ExcelSpec


Pomógł: 158 razy
Posty: 721
Wysłany: 18-12-2018, 03:49   

umiejead napisał/a:
Zdanie kończymy kropką

Komunikaty głosowe z interpunkcją graficzną ... ?
:-> ... toż to tylko głos, czasowo utrwalony w graficznym zobrazowaniu komunikatu dźwiękowego ... :-P

umiejead napisał/a:
kod nie sortuje danych / nie usuwa "śmieciowych" arkuszy

Sortuje i usuwa, a raczej usuwa i sortuje ... :->

... a to w ogóle to jakiś konkurs był ... ? : -() ?
ID posta: 358641 Skopiuj do schowka
 
 
umiejead 
Excel Expert


Pomógł: 228 razy
Posty: 1233
Wysłany: 18-12-2018, 04:17   

FYI: to moja subiektywna ocena. :-P

Cytat:
kod nie sortuje danych / nie usuwa "śmieciowych" arkuszy
Patrz na gwiazdki: to dotyczy kodu kuma. Dlatego wygrałeś. :mrgreen:
_________________
.
Jak poprawnie opisać problem: http://www.excelforum.pl/...ika-vt59262.htm
I dbajmy - proszę - o poprawną polszczyznę.
ID posta: 358643 Skopiuj do schowka
 
 
kuma 
Excel Expert


Pomógł: 1125 razy
Posty: 3382
Wysłany: 18-12-2018, 09:50   

Nie wiem o co Ci chodzi.
Dane są sortowane na samym początku
Kod:
rng.Sort Columns(1), xlAscending, , , , , , xlYes
A czy ma usuwać "zbędne" arkusze?
malya napisał/a:
...będzie przenosiło/grupowało dane filtrując po wartościach pierwszej kolumny i zapisywało je każde w osobnej zakładce, a zakładka otrzyma nazwę jak wartości tych danych.

Pozdrawiam.
ID posta: 358649 Skopiuj do schowka
 
 
umiejead 
Excel Expert


Pomógł: 228 razy
Posty: 1233
Wysłany: 18-12-2018, 17:14   

1. Chodziło mi o kol. B (chociaż faktycznie autor tego nie wymaga).

2. A jeśli autor nadpisze Arkusz1 nowymi danymi?
_________________
.
Jak poprawnie opisać problem: http://www.excelforum.pl/...ika-vt59262.htm
I dbajmy - proszę - o poprawną polszczyznę.
ID posta: 358679 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.marketingNET.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