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: 64363 Skopiuj do schowka makro kopiujące dane pod warunkiem
Autor Wiadomość
ezq
Starszy Forumowicz


Posty: 41
Wysłany: 07-03-2019, 21:11   makro kopiujące dane pod warunkiem

potrzebuję pomocy przy rozwiązaniu tego zadania,
mam 3 arkusze, chciałbym aby makro kopiowało tylko te litery z arkusza wzorzec kolumna A do arkusza wynik do pierwszej pustej kolumny zaczynajac od wiersza drugiego które spełniają warunek,
suma ilości tej litery w arkuszu dane kolumna B jest mniejsza niż limit tej litery w arkuszu wzorzec kolumna B

załączam plik w którym kolorem zaznaczone są litery które powinny być kopiowane w tym konkretnym przypadku

KOPIA.xlsm
Pobierz Plik ściągnięto 22 raz(y) 20.33 KB

ID posta: 363814 Skopiuj do schowka
 
 
kuma 
Excel Expert


Pomógł: 1198 razy
Posty: 3549
Wysłany: 08-03-2019, 08:58   

Witaj. Przetestuj makro
Kod:
Sub Wybrane_litery_kuma()
    Dim i As Integer, k As Integer
    Dim d As Object
    Dim a(), ar
   
    Set d = CreateObject("scripting.dictionary")
    With Sheets("DANE")
        a = .Range("A2:B" & .Cells(Rows.Count, "A").End(3).Row).Value
    End With
    For i = 1 To UBound(a)
        If Len(a(i, 1)) > 0 Then d(a(i, 1)) = d(a(i, 1)) + a(i, 2)
    Next
    With Sheets("WZORZEC")
        a = .Range("A2:B" & .Cells(Rows.Count, "A").End(3).Row).Value
    End With
    ReDim ar(1 To d.Count)
    For i = 1 To UBound(a)
        If d.Item(a(i, 1)) < a(i, 2) Then
            k = k + 1
            ar(k) = a(i, 1)
        End If
    Next
    With Sheets("WYNIK")
        .Cells(2, Columns.Count).End(xlToLeft)(1, IIf(.Cells(2, 1).Value = "", 1, 2)).Resize(UBound(ar)) = Application.Transpose(ar)
    End With
    Set d = Nothing
End Sub
Pozdrawiam.
ID posta: 363833 Skopiuj do schowka
 
 
ezq
Starszy Forumowicz


Posty: 41
Wysłany: 08-03-2019, 20:38   

dzięki kuma, niestety jak dodałem więcej rekordów do wzorca to macro wywala błąd run-time error 9
załączam plik

KOPIA.xlsm
Pobierz Plik ściągnięto 19 raz(y) 34.95 KB

ID posta: 363868 Skopiuj do schowka
 
 
kuma 
Excel Expert


Pomógł: 1198 razy
Posty: 3549
Wysłany: 12-03-2019, 11:58   

Przetestuj
Kod:
Sub Wybrane_litery_kuma()
    Dim i As Integer, k As Integer
    Dim d As Object
    Dim a(), ar
   
    'd.keys
    'd.items
    Set d = CreateObject("scripting.dictionary")
    With Sheets("DANE")
        a = .Range("A2:B" & .Cells(Rows.Count, "A").End(3).Row).Value
    End With
    For i = 1 To UBound(a)
        If Len(a(i, 1)) > 0 Then d(a(i, 1)) = d(a(i, 1)) + a(i, 2)
    Next
    With Sheets("WZORZEC")
        a = .Range("A2:B" & .Cells(Rows.Count, "A").End(3).Row).Value
    End With
    ReDim ar(1 To d.Count)
    For i = 1 To UBound(a)
        If d.Item(a(i, 1)) <> Empty And d.Item(a(i, 1)) < a(i, 2) Then
            k = k + 1
            ar(k) = a(i, 1)
        End If
    Next
    With Sheets("WYNIK")
        .Cells(2, Columns.Count).End(xlToLeft)(1, IIf(.Cells(2, 1).Value = "", 1, 2)).Resize(UBound(ar)) = Application.Transpose(ar)
    End With
    Set d = Nothing
End Sub
Pozdrawiam.
ID posta: 364010 Skopiuj do schowka
 
 
ezq
Starszy Forumowicz


Posty: 41
Wysłany: 13-03-2019, 09:25   

dzięki kuma nie wywala już błędu :), ale jeszcze nie kopiuje numeru jeśli jest np, suma ilości = 0, chciałbym też aby kopiował także te numery z wzorca które nie występują w danych bo wsumie je też muszę liczyć jako 0,
oraz nie tylko mniejsze ale równe też, dzięki za pomoc i wyrozumiałość

KOPIA.xlsm
Pobierz Plik ściągnięto 22 raz(y) 46.26 KB

ID posta: 364075 Skopiuj do schowka
 
 
kuma 
Excel Expert


Pomógł: 1198 razy
Posty: 3549
Wysłany: 13-03-2019, 10:51   

Przetestuj
Kod:
Sub Wybrane_litery_kuma()
    Dim i As Integer, k As Integer
    Dim d As Object
    Dim a(), ar
   
    Set d = CreateObject("scripting.dictionary")
    With Sheets("DANE")
        a = .Range("A2:B" & .Cells(Rows.Count, "A").End(3).Row).Value
    End With
    For i = 1 To UBound(a)
        If Len(a(i, 1)) > 0 Then d(a(i, 1)) = d(a(i, 1)) + a(i, 2)
    Next
    With Sheets("WZORZEC")
        a = .Range("A2:B" & .Cells(Rows.Count, "A").End(3).Row).Value
    End With
    ReDim ar(1 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
        If d.Item(a(i, 1)) <= a(i, 2) Or d.Item(a(i, 1)) = Empty Then
            k = k + 1
            ar(k, 1) = a(i, 1)
        End If
    Next
    With Sheets("WYNIK")
        .Cells(2, Columns.Count).End(xlToLeft)(1, IIf(.Cells(2, 1).Value = "", 1, 2)).Resize(UBound(ar)) = ar
    End With
    Set d = Nothing
End Sub
Pozdrawiam.
ID posta: 364095 Skopiuj do schowka
 
 
ezq
Starszy Forumowicz


Posty: 41
Wysłany: 15-03-2019, 08:04   

dzięki kuma, kod działa tylko zauważyłem jeden mały problemik, otóż normalnie jak porównuje dwie komorki ze sobą to niema znaczenia wielkość liter, natomiast w twoim kodzie ma znaczenie i jak np. we wzorcu mam komurkę Aa a w danych aA to kod widzi je jako dwa różne wpisy, czy można to jakośc zmienić aby wielkość liter nie miała znaczenia?
ID posta: 364269 Skopiuj do schowka
 
 
kuma 
Excel Expert


Pomógł: 1198 razy
Posty: 3549
Wysłany: 15-03-2019, 08:22   

Ok. Poprawiony kod. Wyniki będą zawsze wpisywane dużymi literami bez względu na to jak będą zapisane we wzorcu i danych.
    Zwróć uwagę na ortografię, bo to naprawdę raziiiiii!
Kod:
Sub Wybrane_litery_kuma()
    Dim i As Integer, k As Integer
    Dim d As Object
    Dim a(), ar
   
    Set d = CreateObject("scripting.dictionary")
    With Sheets("DANE")
        a = .Range("A2:B" & .Cells(Rows.Count, "A").End(3).Row).Value
    End With
    For i = 1 To UBound(a)
        If Len(a(i, 1)) > 0 Then d(UCase(a(i, 1))) = d(UCase(a(i, 1))) + a(i, 2)
    Next
    With Sheets("WZORZEC")
        a = .Range("A2:B" & .Cells(Rows.Count, "A").End(3).Row).Value
    End With
    ReDim ar(1 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
        If d.Item(UCase(a(i, 1))) <= a(i, 2) Or d.Item(UCase(a(i, 1))) = Empty Then
            k = k + 1
            ar(k, 1) = UCase(a(i, 1))
        End If
    Next
    With Sheets("WYNIK")
        .Cells(2, Columns.Count).End(xlToLeft)(1, IIf(.Cells(2, 1).Value = "", 1, 2)).Resize(UBound(ar)) = ar
    End With
    Set d = Nothing
End Sub
Pozdrawiam.
ID posta: 364270 Skopiuj do schowka
 
 
ezq
Starszy Forumowicz


Posty: 41
Wysłany: 19-03-2019, 00:29   

to przez dysleksje...
dzięki kuma, działa
ID posta: 364472 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