pimre Creative Commons License 2012.04.08 0 0 17683

Mindenekelőtt egy egszerűsítő javaslat. Az egyes oszloppárokat rendezd le a munka elkezdése előtt a nevek sorrendjében. Hogy ne kelljen a programnak minden alkalommal újra és újra rendezni a teljes állományt. Igaz, hogy a bináris rendező - a quicksort - egy nagyon gyors algoritmus, de jobb elkerülni, hogy mindig újra kelljen rendezni a teljes (egyébként már rendezett) állományt.

 

Szóval, ha már rendezett állományba akarsz új tételt beírni (esetleg egy meglévőt módosítani), akkor a következő megoldást gondolom. A munkalap kódlapjára írd be az alábbi programot:

 

Megjegyzés: A program feltételezi, hogy az adatsorok száma nem haladja meg a 32767-et, ezért integer változókat használ a sorok megadására. A programot teszteltem valamelyest, de azért próbáld ki Te is többféle helyzetben, nem maradt-e benne valami poloska. Ismered a Murphy mondást? "Hibátlan program nincs, csak olyan, amiben még nem találták meg a hibát."

 

Íme a program:

 

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

    Application.EnableEvents = False ' A futtaás alatt kikapcsoljuk

    Dim sor As Integer, oszlop As Integer, utolsósor As Integer, név As String, darabszám As Integer

    sor = Target.Row

    oszlop = Target.Column

    If sor > 7 Then ' Csak ha a 7. sor felett vagyunk

        If oszlop = 1 Or oszlop = 4 Or oszlop = 7 Or oszlop = 10 Or oszlop = 13 Or _

           oszlop = 16 Or oszlop = 19 Or oszlop = 22 Then ' Ha A,D....V oszlopon állunk

            név = Cells(sor, oszlop)

            darabszám = Cells(sor, oszlop + 1)

            Range(Cells(sor, oszlop), Cells(sor, oszlop + 1)).Select

            Selection.Delete Shift:=xlUp ' Töröljük a 2 oszlopadatát, hátha nem a végén vagyunk, hanem egy közbenső adatot javítunk

            ActiveCell.SpecialCells(xlLastCell).Select ' Az utolsó sor

            utolsósor = ActiveCell.Row

            Do While Cells(utolsósor, oszlop) = "" ' A végén lévő üreseket kihagyjuk

                utolsósor = utolsósor - 1 ' Sajnos erre kapásból nem tudok elegánsabb megoldást

            Loop

            sor = keresés(8, utolsósor, oszlop, név)

            Range(Cells(sor, oszlop), Cells(sor, oszlop + 1)).Select

            Selection.Insert Shift:=xlDown

            Cells(sor, oszlop) = név

            Cells(sor, oszlop + 1) = darabszám

         End If

    End If

    Application.EnableEvents = True

End Sub

 

Function keresés(elsősor As Integer, utolsósor As Integer, oszlop As Integer, név As String)

Dim aktsor As Integer, kezdet As Integer, vég As Integer, megvan As Boolean

kezdet = elsősor

vég = utolsósor

megvan = False

If név <= Cells(kezdet, oszlop) Then ' Ha kisebb az elsőnél, vagy egyenlő vele

    aktsor = kezdet

    megvan = True

ElseIf név >= Cells(vég, oszlop) Then ' Ha nagyobb az utolsónál, vagy egyenlő vele

    aktsor = vég + 1

    megvan = True

End If

Do While Not megvan

    aktsor = Int((kezdet + vég) / 2)

    If név < Cells(aktsor, oszlop) Then

        vég = aktsor

    ElseIf név > Cells(aktsor, oszlop) Then

        kezdet = aktsor

    Else

        megvan = True

    End If

    If vég = kezdet + 1 And Not megvan Then ' Ha egymás mellett vannak

        megvan = True

        aktsor = aktsor + 1 ' Akkor a következő névre állunk, és majd elé szúrjuk be

    End If

Loop

keresés = aktsor

End Function

 

Előzmény: Sovimigo (17682)