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: 64223 Skopiuj do schowka kopia do nowego arkusza z warunkami/usunięcie duplikatów
Autor Wiadomość
Actimel
Starszy Forumowicz


Posty: 27
Wysłany: 22-02-2019, 13:42   kopia do nowego arkusza z warunkami/usunięcie duplikatów

Witam,
Mam harmonogram czynności dla poszczególnych klientów (daty).
Na podstawie 3 kolumn - jednoznacznie identyfikuję czynność (zaznaczone w przykładzie na żółto [Nr klienta; Kod_uslugi; Czestotliwosc ])

Założyłem, że będę kopiował arkusz do nowego, z uwzględnieniem poniższego:

Jeżeli dana czynność się powtarza( dane z 3 ww kolumn są te same), to muszę je scalić do 1 wiersza, przy czym:
- daty z drugiego (i kolejnych) wierszy są do pierwszego kopiowane (dodawane) i wszystkie daty w tym wierszu są sortowane
- jeżeli daty się powtarzają to duplikaty usuwamy. Może być cały wiersz zduplikowany (wówczas wszystkie daty usuwamy). Są też przypadki, że tylko część dat jest zduplikowane i te tylko usuwamy tylko.
Liczba dat (kolumn) może być różna

W załączniku przykład (żródło - Arkusz 'Daty' oraz efekt - czyli co ma być wynikiem).

Z góry dziękuję za każdą pomoc.

Harm_1.xlsx
Pobierz Plik ściągnięto 22 raz(y) 44.73 KB

ID posta: 363106 Skopiuj do schowka
 
 
kuma 
Excel Expert


Pomógł: 1198 razy
Posty: 3549
Wysłany: 22-02-2019, 20:10   

Przetestuj moją propozycję rozwiązania.
Dodaj nowy arkusz i nazwij go 'Arkusz1 lub po swojemu, ale musisz zmienić wtedy nazwę arkusza w moim kodzie.
Do nowego arkusza skopiuj nagłówki z arkusza 'Daty'. Kod wklej do modułu normalnego VBA.
Kod:
Sub Unikaty_Klient()
    Dim i As Integer, ii As Integer, j As Integer, lr As Integer, lc As Integer
    Dim a(), k, kk, v, cls
    Dim d As Object, lst As Object
    Dim ms As String

    Application.ScreenUpdating = False
    Set lst = CreateObject("System.Collections.ArrayList")
    Set d = CreateObject("scripting.dictionary")
    With Sheets("Daty")
        lr = .Cells(.Rows.Count, "A").End(3).Row
        lc = .UsedRange.Columns.Count
        a = .Range(.Cells(2, 1), .Cells(lr, lc)).Value
        ReDim cls(1 To lc)
        For i = 1 To lc: cls(i) = i:  Next
    End With
    With d
        For i = 1 To UBound(a)
            ms = a(i, 1) & a(i, 7) & a(i, 8)
            If .exists(ms) Then
                .Item(ms).Item(i) = i
            Else
                Set .Item(ms) = CreateObject("Scripting.Dictionary")
                .Item(ms).Item(i) = i
            End If
        Next i
    End With
    For Each k In d.Keys
        j = d.Item(k).Count
        If j > 1 Then
            lst.Clear
            For Each kk In d.Item(k).Keys
                For ii = 9 To lc
                    If Len(a(kk, ii)) = 0 Then Exit For
                    If Not lst.Contains(a(kk, ii)) Then lst.Add a(kk, ii)
                Next
            Next
            lst.Sort
            v = d.Item(k).Keys
            d(k) = Array(v(0), lst.toarray)
        End If
    Next
    Application.ScreenUpdating = False
    With Sheets("Arkusz1")
        .[A1].CurrentRegion.Offset(1, 0).ClearContents
        If d.Count > 0 Then
            For Each k In d.Keys
                If Not IsArray(d.Item(k)) Then
                    v = d.Item(k).Keys
                    .Range("A" & .Cells(Rows.Count, "A").End(xlUp).Row)(2).Resize(1, UBound(cls)) = _
                                Application.Index(a, v(0), cls)
                Else
                    v = d.Item(k)(1)
                    .Range("A" & .Cells(Rows.Count, "A").End(xlUp).Row)(2).Resize(1, 8) = _
                                        Application.Index(a, d.Item(k)(0), Array(1, 2, 3, 4, 5, 6, 7, 8))
                    .Range("I" & .Cells(Rows.Count, "A").End(xlUp).Row)(1).Resize(1, UBound(v) + 1) = v
                End If
            Next
        End If
    End With
    Set d = Nothing
    Set lst = Nothing
End Sub
Pozdrawiam.
ID posta: 363131 Skopiuj do schowka
 
 
Actimel
Starszy Forumowicz


Posty: 27
Wysłany: 25-02-2019, 14:41   

Na szybko wygląda OK.
Sprawdzę wieczorem jeszcze na większej ilości danych
ID posta: 363227 Skopiuj do schowka
 
 
Actimel
Starszy Forumowicz


Posty: 27
Wysłany: 27-02-2019, 09:50   

Działa super - dzięki serdeczne!!
ID posta: 363332 Skopiuj do schowka
 
 
Bill Szysz 
Excel Expert


Wersja: Win Office 365
Pomógł: 794 razy
Posty: 3302
Wysłany: 27-02-2019, 11:47   

Dorzucę się z rozwiązaniem w PQ.

Harm_1_BS_PQ.xlsx
Pobierz Plik ściągnięto 13 raz(y) 110.39 KB

_________________
Szkolenia z Power Query!!!

Pozdrawiam, były szbill62 aktualnie Bill Szysz
ID posta: 363346 Skopiuj do schowka
 
 
Actimel
Starszy Forumowicz


Posty: 27
Wysłany: 01-03-2019, 11:29   

nie mam niestety jak sprawdzić - moja wersja Office'a nie obsługuje Power Query
ID posta: 363495 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