[VBA] Kod makro do Excela 2007 - sortowanie wg nazwisk

Dla specjalistów Programowanie
#1

Witam!

Chciałbym się zapytać czy ktoś zna się dobrze na VBA i wie do czego służy poniższe makro do Excela ponieważ mam do niego kilka pytań. Dodam, że aby go zrozumieć, należy znać zasadę działania algorytmu quicksort, gdzie element osiowy znajduje się “na początku”…

Public Sub sortuj()

  Dim liczbaWierszy As Integer

  liczbaWierszy = Application.Selection.Rows.Count

  Application.ScreenUpdating = False

  Call qsort(1, liczbaWierszy)

End Sub

_________________________________________________________________


Private Sub qsort(lewa, prawa)

  Dim m As Integer

  Dim i As Integer

  If lewa < prawa Then

    m = lewa

    i = lewa + 1

    Do While (i <= prawa)

      If porównaj(i, lewa) < 0 Then

        m = m + 1

        Call zamień(m, i)

      End If

      i = i + 1

    Loop

    Call zamień(lewa, m)

    Call qsort(lewa, m - 1)

    Call qsort(m + 1, prawa)

  End If

End Sub

_________________________________________________________________


Private Function porównaj(i1, i2) As Integer

  c1 = Application.Selection.Rows(i1).Cells(1, 1)

  c2 = Application.Selection.Rows(i2).Cells(1, 1)


  poz1 = InStr(c1, " ")

  poz2 = InStr(c2, " ")


  If poz1 Then

    str1 = Mid(c1, poz1 + 1)

  Else

    str1 = ""

  End If


  If poz2 Then

    str2 = Mid(c2, poz2 + 1)

  Else

    str2 = ""

  End If


  porównaj = StrComp(str1, str2, vbTextCompare)

End Function

_________________________________________________________________


Private Sub zamień(i1, i2)

  If i1 = i2 Then

    Exit Sub

  End If

  If i1 > i2 Then

    Dim temp

    temp = i2

    i2 = i1

    i1 = temp

  End If

  Application.Selection.Rows(i1).Copy

  Application.Selection.Rows(i2).Insert

  Application.Selection.Rows(i2 + 1).Copy (Application.Selection.Rows(i1))

  Application.Selection.Rows(i2 + 1).Delete

End Sub

A teraz pytanie: Pewien fragment powyższego kodu wygląda tak:

If porównaj(i, lewa) < 0 Then

A ta funkcja porównaj ma pierwszą linijkę następującą:

Private Function porównaj(i1, i2) As Integer

Później i1 odpowiada zmienna str1, i2 odpowiada str2 - kto rozumie kod wie o co mi chodzi…

Czyli można można powiedzieć, że z kodu 1 - szego, zmiennej i odpowiada str1, a zmiennej lewa odpowiada str2 :?: (I potem aby warunek był true, zmienna lewa musi być mniejsza od zmiennej iteracyjnej i - zgodnie z zasadą działania quicksort).

Z góry byłbym bardzo wdzięczny za pomoc :wink:

#2

:?: to makro powinno sortować … ale nie sortuje

założenia były takie, żeby w zaznaczonych komórkach posortować rekordy

pobrać pierwszy i sprawdzić go z następnym i o ile alfabetycznie jest wyżej

przesunąć go powyżej … niedokładnie skopiowałeś prawdopodobnie

#3

Chodziło o to, żeby posortować imienia i nazwiska względem nazwiska. Imiona i nazwiska były w dwóch scalonych wierszach. U mnie to działa… (Excel 2007)

#4

Faktycznie Quentin nie wpisywałem drugiego ciągu czyli nazwiska i nie zauważyłem

… ale czego nie rozumiesz, bo dobrze kombinujesz (nie używaj tylko w zmiennych i nazwach funkcji polskich znaków)

Public Sub sortuj_Im_Naz()

    Dim liczbaZaznaczWierszy As Integer

    liczbaZaznaczWierszy = Application.Selection.Rows.Count

    Application.ScreenUpdating = False 'wyłaczenie odswieżania (przyspieszenie)

    Call proceduraQSort(1, liczbaZaznaczWierszy)

End Sub


Private Sub proceduraQSort(pierwszyWiersz, ostatniWiersz)

    Dim sprawdzanyWiersz As Integer

    Dim nastepnyWiersz As Integer

    If pierwszyWiersz < ostatniWiersz Then

        sprawdzanyWiersz = pierwszyWiersz

        nastepnyWiersz = pierwszyWiersz + 1

        Do While (nastepnyWiersz <= ostatniWiersz)

            If funkcjaPorownaj(nastepnyWiersz, pierwszyWiersz) < 0 Then

                sprawdzanyWiersz = sprawdzanyWiersz + 1

                Call zamienMiejscami(sprawdzanyWiersz, nastepnyWiersz)

            End If

            nastepnyWiersz = nastepnyWiersz + 1

        Loop

        Call zamienMiejscami(pierwszyWiersz, sprawdzanyWiersz)

        Call proceduraQSort(pierwszyWiersz, sprawdzanyWiersz - 1)

        Call proceduraQSort(sprawdzanyWiersz + 1, ostatniWiersz)

    End If

End Sub


Private Function funkcjaPorownaj(numerPierwszego, numerDrugiego) As Integer

    tekstPierwszego = Application.Selection.Rows(numerPierwszego).Cells(1, 1)

    tekstDrugiego = Application.Selection.Rows(numerDrugiego).Cells(1, 1)

    spacjaPierwszego = InStr(tekstPierwszego, " ")

    spacjaDrugiego = InStr(tekstDrugiego, " ")

    If spacjaPierwszego Then

            nazwiskoPierwsze = Mid(tekstPierwszego, spacjaPierwszego + 1)

        Else

            nazwiskoPierwsze = ""

    End If

    If spacjaDrugiego Then

            nazwiskoDrugie = Mid(tekstDrugiego, spacjaDrugiego + 1)

        Else

            nazwiskoDrugie = ""

    End If

    funkcjaPorownaj = StrComp(nazwiskoPierwsze, nazwiskoDrugie, vbTextCompare)

End Function


Private Sub zamienMiejscami(numerPierwszego, numerDrugiego)

    If numerPierwszego = numerDrugiego Then Exit Sub

    If numerPierwszego > numerDrugiego Then

        Dim zapamietajWiersz

        zapamietajWiersz = numerDrugiego

        numerDrugiego = numerPierwszego

        numerPierwszego = zapamietajWiersz

    End If

    Application.Selection.Rows(numerPierwszego).Copy

    Application.Selection.Rows(numerDrugiego).Insert

    Application.Selection.Rows(numerDrugiego + 1).Copy (Application.Selection.Rows(numerPierwszego))

    Application.Selection.Rows(numerDrugiego + 1).Delete

End Sub

myślę ze teraz będzie to zrozumiałe

przydała by się jeszcze funkcja sortująca imię bo zdarza się ze Adam Abacki może być niżej niż Zenon Abacki

#5

Dzięki wielkie YaSam za zmodyfikowanie tego makra - teraz już więcej kapuję :wink: