Excel Forum - Porady, Pomoc, Excel Help, Excel FAQ - Makro zliczające na podstawie zawartości

VeX85 · Forumowicz Wersja: Win Office 2016 Posty: 14

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 12 raz(y) 10.82 KB

xfish · 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 8 raz(y) 13.77 KB

Kaper · 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 9 raz(y) 15.27 KB

Maciej Gonet · 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 9 raz(y) 21.37 KB

Kaper · 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 7 raz(y) 12.45 KB

Maciej Gonet · 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 6 raz(y) 12.41 KB

Kaper · 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 8 raz(y) 12.8 KB

VeX85 · Forumowicz Wersja: Win Office 2016 Posty: 14

Dziękuję za odpowiedzi, faktycznie tabela przestawna da taki sam efekt ale i makro działa :clap

Kaper · 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