Excel Forum - Porady, Pomoc, Excel Help, Excel FAQ - Makro "Multilos"

geniu7 · Wysłany: 25-06-2012, 22:44 **Makro "Multilos"**

Wtam ponownie wszystkich forumowiczów. W załączniku przykładowy zeszyt a w nim przypiete makro "Multilos II", które przelicza wystapienia liczb po zadanej liczbie i wyświetla następne losowanie po danej liczbie. Nie wiem czy to jest zrozumiałe. Przedstawię to obrazowo. W arkuszu "Liczby......." w komórce "X7" wpisuję np. "6" i klikając w przycisk "Oblicz liczby" makro przelicza arkusz "Baza" i w kolumnie "A" wyświetla w jakich losowaniach liczba "6" brała udział zaś w kolumnach "B-U" wyświetla nastepne losowania jakie nastąpiły po "6". Cały czas mówimy o arkuszu "Liczby 1-2-3-4-5".Jeśli dajmy na to w "X7" wpiszę "6" i "Y7" wpisze "9" to przeliczenia będą się odnosić do dwóch liczb, ale zawsze nastepne jedno losowanie. I to jest wszystko OK. Chodzi mi o nastepne makro no powiedzmy "Multilos III", które przeliczy nie jedno lecz trzy następne losowania. Wpisując w komórkę "Z10" jedną liczbę no powiedzmy "11" i klikając na przycisk "Oblicz" makro przeliczy arkusz "Baza" i w arkuszu "Liczby........." w kolumnach "B-U" przedstawi po trzy następne losowania po "11". Zrobiłem próbę i wyglądałoby to tak. Liczba "11" wystąpiła w 3,5 8,15,26.........losowaniach, w kolumnie "B-U" powinny być wyświetlone nastepujące losowania: 4,5,6,7,8,9,10,11,16,17,18,27,28,29. Pytanie do Was drodzy forumowicze: Czy da się coś takiego zrobić. Liczę na Was. Jak do tej pory nigdy się nie zawiodłem.
Pozdrawiam

Zeszyt2.rar

Pobierz Plik ściągnięto 304 raz(y) 277.86 KB

Marecki · Wysłany: 28-06-2012, 11:36

Hejka.
Wypociłem takie makro:

Kod:

Option Explicit
Sub MultilosIII()
Dim ost&, ost1&, i&, w&
Dim x As Byte
Dim kom As Range
ost = 1
ost1 = Worksheets("Baza").Cells(Rows.Count, 2).End(xlUp).Row
x = Range("Z10")

With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With

Columns("A:U").ClearContents

For Each kom In Sheets("Baza").Range("d1:w50") '" & ost1) ' Wykasować 50") ' dla całego zakresu
If kom.Value = x Then
For i = 1 To 3
Application.Union(Sheets("Baza").Range("A" & kom.Row + i), Sheets("Baza").Range("D" & kom.Row + i & ":W" & kom.Row + i)).Copy
w = Worksheets("Baza").Range("A" & kom.Row + i)
On Error Resume Next
w = Range("a" & ost & ":a" & ost + 2).Find(What:=w)
If Err.Number = 91 Then
On Error GoTo 0
Range("a" & ost).PasteSpecial
ost = ost + 1
End If
Next i
End If
Next kom

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub

, które na razie ograniczyłem do 50-ciu wierszy, ponieważ długo się wykonuje.
Prośba o przerobienie makra w taki sposób aby poszczególne wiersze z Application.Union zapisywało do tablicy a potem całą tablicę przeniosło do arkusza Liczby 1-2-3-4-5.
Czytam o tych tablicach i czytam i nic mi nie wychodzi. :cry:

geniu7 · Wysłany: 28-06-2012, 20:32

Wielkie dzięki Marku. Rzeczywiście, przy całym zakresie trochę długo oblicza, ale oblicza. Jak będziesz mógł i to poprawić, to bardzo byłbym wdzięczny. Nie miałem pojęcia, że to takie trudne.

Marecki · Wysłany: 29-06-2012, 19:39

Cytat:

Nie miałem pojęcia, że to takie trudne.

Trudne nie jest, jak się wie co i jak, a że dopiero raczkuje w VBA to kod wyszedł jaki wyszedł (tworzyłem te pętle i się zapętliłem :lol:

)
Podejrzałem kod w Multilos II i wyszło coś takiego:

Kod:

Option Explicit
Sub MultilosIII()
Application.ScreenUpdating = False
Dim a&, ost&, x&, i&, j&, Z As Range
Dim Wks As Worksheet: Set Wks = ThisWorkbook.ActiveSheet
Dim WksB As Worksheet: Set WksB = ThisWorkbook.Worksheets("Baza")

ost = WksB.Cells(Rows.Count, 2).End(xlUp).Row
a = 1
x = Cells(10, "Z").Value
Range("A:U").ClearContents

If x > 0 Then
With WksB
For i = 1 To ost
Set Z = .Range("D" & i & ":W" & i)
If Not IsError(Application.Match(x, Z, 0)) Then
Wks.Range("b" & a & ":u" & a + 2).Value = .Range("d" & i + 1 & ":w" & i + 3).Value
Wks.Range("a" & a & ":a" & a + 2).Value = .Range("a" & i + 1 & ":a" & i + 3).Value
a = a + 3
End If
Next i
End With
End If

Columns("A:U").RemoveDuplicates 1

Set Z = Nothing
Set Wks = Nothing
Set WksB = Nothing

Application.ScreenUpdating = True

End Sub

geniu7 · Wysłany: 30-06-2012, 08:53

No, pięknie. Teraz chodzi znacznie szybciej i prawidłowo wyświetla losowania. Brawo Marku.