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: 73277 Skopiuj do schowka Makro zliczające na podstawie zawartości
Autor Wiadomość
VeX85 
Forumowicz


Wersja: Win Office 2016
Posty: 14
Wysłany: 25-08-2022, 07:00   Makro zliczające na podstawie zawartości

Witam Ekspertów :-)
Piszę z zapytaniem jak powinien wyglądać kod który by zliczał ilość powtórzeń tej samej wartości z kolumny A na podstawie danych zawartych w kolumnie B a następnie przedstawiał wynik w drugim utworzonym arkuszu ?

W załączniku plik jaki efekt finalny chciałbym osiągnąć :-> . Arkusz1 dane a wynik w Arkusz2.

ilość powtórzeń - przykład.xlsx
Pobierz Plik ściągnięto 10 raz(y) 10.82 KB

ID posta: 419971 Skopiuj do schowka
 
 
xfish 
Excel Expert



Wersja: Win Office 2013
Pomógł: 702 razy
Posty: 2087
Wysłany: 25-08-2022, 08:03   

Niepotrzebne do tego makro.
Tabela przestawna sobie z tym poradzi.

Kopia ilo¶ć powtórzeń - przykład.xlsx
Pobierz Plik ściągnięto 6 raz(y) 13.77 KB

_________________
Pozdrawiam xFish
ID posta: 419973 Skopiuj do schowka
 
 
Kaper 



Zaproszone osoby: 2
Wersja: Win Office 365
Pomógł: 4362 razy
Posty: 8612
Wysłany: 25-08-2022, 08:04   

A dlaczego makro, a nie wykorzystanie tabeli przestawnej? Zobacz załącznik


PS. A makro mogłoby wyglądać np. tak:

Kod:
Sub test()
Dim dict As Object, i As Long, zestaw As String, arr, res, klucz, haslo
Set dict = CreateObject("Scripting.Dictionary")
With Sheets("Arkusz1")
  arr = .Range(.Cells(2, "A"), .Cells(.Rows.Count, "B").End(xlUp)).Value
End With
For i = 1 To UBound(arr)
  zestaw = arr(i, 1) & ";" & arr(i, 2)
  dict(zestaw) = IIf(dict.exists(zestaw), dict(zestaw) + 1, 1)
Next i
ReDim res(1 To dict.Count, 1 To 3)
i = 1
For Each klucz In dict
  haslo = Split(klucz, ";")
  res(i, 1) = haslo(0)
  res(i, 2) = haslo(1)
  res(i, 3) = dict(klucz)
  i = i + 1
Next klucz
With Sheets("Arkusz2")
  .Range(.Cells(2, "A"), .Cells(.Rows.Count, "C")).ClearContents
  .Cells(2, "A").Resize(dict.Count, 3).Value = res
End With
End Sub


ilość powtórzeń - przykład.xlsx
Pobierz Plik ściągnięto 6 raz(y) 15.27 KB

_________________
Kaper Jej Królewskiej Mości :boss

Jeśli dane będą torturowane dość długo, przyznają się do wszystkiego
ID posta: 419974 Skopiuj do schowka
 
 
Maciej Gonet 
Excel Expert


Wersja: Win Office 365
Pomógł: 2827 razy
Posty: 8516
Wysłany: 25-08-2022, 09:24   

No to jeszcze inne makro - bez słownika, z wykorzystaniem CountIfs:
Kod:
Sub Konsoliduj()
   Dim src As Worksheet
   Dim daneA As Range, daneB As Range
   Dim ostw As Long, lw As Long
   With Range("A1:C1")
      .CurrentRegion.Clear
      .Value = Array("Nazwa towaru", "Miejsce", "Ilość")
      .Font.Bold = True
      .HorizontalAlignment = xlCenter
   End With
   Set src = Arkusz1
   ostw = src.Cells(src.Rows.Count, 1).End(xlUp).Row
   With Range("A2:B" & ostw)
      .Value = src.Range("A2:B" & ostw).Value
      .RemoveDuplicates Columns:=Array(1, 2)
   End With
   Set daneA = src.Range("A2:A" & ostw)
   Set daneB = daneA.Offset(, 1)
   lw = Cells(Rows.Count, 1).End(xlUp).Row - 1
   Cells(2, 3).Resize(lw).Value = Application.CountIfs( _
      daneA, Cells(2, 1).Resize(lw).Value, _
      daneB, Cells(2, 2).Resize(lw).Value)
   Range("A1").CurrentRegion.Columns.AutoFit
   Range("A1").CurrentRegion.Select
End Sub
Uruchomienie i wyniki w Arkuszu3.

ilość powtórzeń - przykład.xlsm
Pobierz Plik ściągnięto 7 raz(y) 21.37 KB

ID posta: 419980 Skopiuj do schowka
 
 
Kaper 



Zaproszone osoby: 2
Wersja: Win Office 365
Pomógł: 4362 razy
Posty: 8612
Wysłany: 25-08-2022, 09:38   

To jeszcze do kompletu formuły (zakładając, że masz aktualną wersję, czyli Excela 365 - uzupełnij tą informację w swoim profilu: https://www.excelforum.pl...ode=editprofile )
Formuły w wersji ang. ale jeśli masz PL, to po otwarciu załącznika będą widoczne po polsku:
w A1:
Kod:
=UNIQUE(Arkusz1!A1:B18) 

w C2 i kopia w dół (może być z zapasem):
Kod:
=IF(B2="";"";COUNTIFS(Arkusz1!A:A;A2;Arkusz1!B:B;B2))

i już

ilość powtórzeń - przykład (1).xlsx
Pobierz Plik ściągnięto 5 raz(y) 12.45 KB

_________________
Kaper Jej Królewskiej Mości :boss

Jeśli dane będą torturowane dość długo, przyznają się do wszystkiego
ID posta: 419982 Skopiuj do schowka
 
 
Maciej Gonet 
Excel Expert


Wersja: Win Office 365
Pomógł: 2827 razy
Posty: 8516
Wysłany: 25-08-2022, 10:25   

Jeśli chodzi o rozwiązanie formułami w nowym Excelu, to moja sugestia byłaby taka.
Zostawić nagłówki w spokoju (przekopiować je ręcznie). Funkcję UNIKATOWE zastosować od drugiego wiersza:
Kod:
=UNIKATOWE(Arkusz1!A2:B18)

a w trzeciej kolumnie wykorzystać odwołanie dynamiczne i nic nie trzeba będzie kopiować:
Kod:
=LICZ.WARUNKI(Arkusz1!A:A;INDEKS(A2#;;1);Arkusz1!B:B;INDEKS(A2#;;2))


ilość powtórzeń - przykład (2).xlsx
Pobierz Plik ściągnięto 4 raz(y) 12.41 KB

ID posta: 419985 Skopiuj do schowka
 
 
Kaper 



Zaproszone osoby: 2
Wersja: Win Office 365
Pomógł: 4362 razy
Posty: 8612
Wysłany: 25-08-2022, 10:39   

To może kolejne uproszczenie - dane w arkuszu1 umieścić w tablicy
Wtedy dodawanie kolejnych wierszy automatycznie zaktualizuje zakres, a pierwsza formuła będzie jeszcze prostsza:
Kod:
=UNIKATOWE(Table1)


ilość powtórzeń - przykład (3).xlsx
Pobierz Plik ściągnięto 6 raz(y) 12.8 KB

_________________
Kaper Jej Królewskiej Mości :boss

Jeśli dane będą torturowane dość długo, przyznają się do wszystkiego
ID posta: 419987 Skopiuj do schowka
 
 
VeX85 
Forumowicz


Wersja: Win Office 2016
Posty: 14
Wysłany: 25-08-2022, 10:44   

Dziękuję za odpowiedzi, faktycznie tabela przestawna da taki sam efekt ale i makro działa :clap
ID posta: 419988 Skopiuj do schowka
 
 
Kaper 



Zaproszone osoby: 2
Wersja: Win Office 365
Pomógł: 4362 razy
Posty: 8612
Wysłany: 25-08-2022, 10:47   

Super,

To jeszcze przypomnienie o uzupełnieniu profilu, wspominanym w http://www.excelforum.pl/viewtopic.php?p=419982
_________________
Kaper Jej Królewskiej Mości :boss

Jeśli dane będą torturowane dość długo, przyznają się do wszystkiego
ID posta: 419989 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