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