[-Koppel-]

On kolm tulpa asju ning oleks nende vahele vaja lisada uusi nii, et talle järgnevad ussina alla liiguks.

1 - 2 - 3
4 - 5 - 6
7 - 8 - 9

Ja kui lisan ühe celli juurde, siis ei oleks mitte

1 - 2 - X - 3
4 - 5 - 6
7 - 8 - 9

vaid see kõrvale nihutatud cell liigutaks talle järgnevaid ussina edasi.

1 - 2 - X
3 - 4 - 5
6 - 7 - 8
9

Asja teeb pisut keerukamaks ka asjaolu, et iga element koosneb tegelikult neljast üksteise all olevast cellist. Üks pilt ja kolm rida kirjeldust.

[alfreedo]

On vast möttekam laadida mingi näitefail kuhugi üles, et saada selgem pilt "asjadest" ja "asjaoludest"!

[pmq]

Ei midagi ülemäära ilusat, aga peaks toimima nii nagu tahtsid. Eeldusel et õigesti aru sain
Insert käsu asemel kasuta nüüd samas menüüs olevat valikut 'Lisa uus element'.

VBA-s kopeeri järgnev õige Sheet objekti koodilehele:

Spoiler

Option Explicit Private Const BUTTON_CAPTION As String = "Lisa &uus element" Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)     Dim objButton As CommandBarButton         ' Eemaldame nupu, kui kogemata juba olemas on     On Error Resume Next     With Application.CommandBars("Cell")         Call .Controls(BUTTON_CAPTION).Delete     End With     On Error GoTo 0         ' Lisame nupu     Set objButton = Application.CommandBars("Cell").Controls.Add(Type:=msoControlButton, Temporary:=True, Before:=1)             ' Ja määrame selle omadused     With objButton         .Style = msoButtonIconAndCaption                                                        'Stiil         .Caption = BUTTON_CAPTION                                                               'Tekst         .FaceId = 59                                                                            'Naerunägu         .OnAction = "'" & ThisWorkbook.Name & "'!'lisa_element (""" + Target.address + """)'"   'Ja käivitame makro koos lahtri aadressiga, kus parem klikk tehti     End With End Sub

Seejärel lisa uus moodul (Insert - Module), ja kopeeri sinna:

Spoiler

Option Explicit Sub lisa_element(address As String)         Dim algus_rida As Integer, algus_veerg As Integer     Dim mitu_rida As Integer, mitu_veergu As Integer, reakordaja As Integer     Dim rida As Integer, veerg As Integer, reamuutus As Integer, veerumuutus As Integer     Dim aitab As Boolean         algus_rida = 2                  'Millisel real on esimesed andmed     algus_veerg = 2                 'Millises veerus on esimesed andmed     mitu_rida = 9                   'Mitme reagrupiga tegeleme (hetkel kuni 9 neljarealist gruppi)     mitu_veergu = 3     reakordaja = 4                  'Mitu rida ühes reagrupis on     If Application.Intersect(Range(address), Range(Cells(algus_rida, algus_veerg), Cells(algus_rida + mitu_rida * reakordaja, algus_veerg + mitu_veergu))) Is Nothing Then         'Kui oleme piirkonnast väljas, siis ei tee midagi     Else         'Kui parem klikk toimus meid huvitavas piirkonnas, hakkame elemente edasi kopeerima, kuni jõuame uue elemendi kohani         Application.ScreenUpdating = False         aitab = False         For rida = algus_rida + mitu_rida * reakordaja To algus_rida Step -reakordaja             If aitab = True Then Exit For             For veerg = algus_veerg + mitu_veergu - 1 To algus_veerg Step -1                 reamuutus = Int((veerg - algus_veerg + 1) / mitu_veergu)                 veerumuutus = 1 - mitu_veergu * reamuutus                 Range(Cells(rida, veerg), Cells(rida + reakordaja - 1, veerg)).Copy                 Cells(rida + reamuutus * reakordaja, veerg + veerumuutus).Select                 ActiveSheet.Paste                 If Application.Intersect(Range(address), Range(Cells(rida, veerg), (Cells(rida + reakordaja - 1, veerg)))) Is Nothing Then                 Else                     'Teeme lahtrid tühjaks, ja lõpetame                     Range(Cells(rida, veerg), Cells(rida + reakordaja - 1, veerg)).Clear                     aitab = True                     Exit For                 End If             Next veerg         Next rida         Application.ScreenUpdating = True     End If End Sub

Sub 'Lisa_element' alguses olevad muutujad väärtusta endale sobivalt!

[alfreedo]

vwg.
Ma sain jälle aru, et Koppel soovis lahtri lisamist kindla piirkonna teiste lahtrite sekka liigutades lahtri vana sisu edasi piirkonna siseselt.
Tema viimane lause:

[pmq]

Saime siis samamoodi aru, mulle tundub et kood nii ka toimib.
Ning neljast üksteise all olevast cellist elemendi kohta sain aru nii, nagu lisatud failis.
http://pets.planet.ee/elementide_liigutamine.xlsm

Mu eelmises postis oli viga sees, .Copy asemel peab olema .Cut
Siis toimub ka shape objektide esinemisel piirkonnas asi ootuspäraselt.

[-Koppel-]

Toimib täpselt nii nagu esimeses postis kirjeldatud.
Kui keeruline oleks kustutamise funktsiooni lisamine? Kuna undo varianti VBA puhul ei ole, siis kustutamine taastaks samuti eelneva olukorra. Lisaks võib millegi kustutamist ka niisama vaja minna.

Olen tegelikult natuke üllatunud, et sellist funktsiooni Exceli pika elutee jooksul juba kohe sisse ei ole ehitatud. Tekst liigub igalpool ju täpselt sama loogika järgi.

[pmq]

Pole probleemi

Sheet:

Spoiler

Option Explicit Private Const BUTTON_CAPTION As String = "Lisa &uus grupp" Private Const BUTTON_CAPTION_2 As String = "Kustuta &grupp" Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)     Dim objButton As CommandBarButton, objButton2 As CommandBarButton         ' Eemaldame nupud, kui kogemata juba olemas on     On Error Resume Next     With Application.CommandBars("Cell")         Call .Controls(BUTTON_CAPTION).Delete         Call .Controls(BUTTON_CAPTION_2).Delete     End With     On Error GoTo 0         ' Lisame nupud uuesti     Set objButton = Application.CommandBars("Cell").Controls.Add(Type:=msoControlButton, Temporary:=True, Before:=1)     Set objButton2 = Application.CommandBars("Cell").Controls.Add(Type:=msoControlButton, Temporary:=True, Before:=2)             ' Ja määrame nende omadused     With objButton         .Style = msoButtonIconAndCaption                                                        'Stiil         .Caption = BUTTON_CAPTION                                                               'Tekst         .FaceId = 59                                                                            'Naerunägu         .OnAction = "'" & ThisWorkbook.Name & "'!'lisa_element (""" + Target.address + """)'"   'Ja käivitame makro koos lahtri aadressiga, kus parem klikk tehti     End With     With objButton2         .Style = msoButtonIconAndCaption         .Caption = BUTTON_CAPTION_2         .FaceId = 276         .OnAction = "'" & ThisWorkbook.Name & "'!'eemalda_element (""" + Target.address + """)'"     End With End Sub

Moodul:

Spoiler

Option Explicit Const algus_rida = 2                    'Millisel real on esimesed andmed Const algus_veerg = 2                   'Millisel real on esimesed andmed Const mitu_rida = 9                     'Mitme reagrupiga tegeleme (hetkel kuni 9 neljarealist gruppi) Const mitu_veergu = 3 Const reakordaja = 4                    'Mitu rida ühes reagrupis on Sub lisa_element(address As String)         Dim rida As Integer, veerg As Integer, reamuutus As Integer, veerumuutus As Integer     Dim aitab As Boolean         If Application.Intersect(Range(address), Range(Cells(algus_rida, algus_veerg), Cells(algus_rida + mitu_rida * reakordaja, algus_veerg + mitu_veergu))) Is Nothing Then         'Kui oleme piirkonnast väljas, siis ei tee midagi     Else         'Kui parem klikk toimus meid huvitavas piirkonnas, hakkame elemente edasi kopeerima, kuni jõuame uue elemendi kohani         Application.ScreenUpdating = False         aitab = False         For rida = algus_rida + mitu_rida * reakordaja To algus_rida Step -reakordaja             If aitab = True Then Exit For             For veerg = algus_veerg + mitu_veergu - 1 To algus_veerg Step -1                 reamuutus = Int((veerg - algus_veerg + 1) / mitu_veergu)                 veerumuutus = 1 - mitu_veergu * reamuutus                 Range(Cells(rida, veerg), Cells(rida + reakordaja - 1, veerg)).Cut                 Cells(rida + reamuutus * reakordaja, veerg + veerumuutus).Select                 ActiveSheet.Paste                 If Application.Intersect(Range(address), Range(Cells(rida, veerg), (Cells(rida + reakordaja - 1, veerg)))) Is Nothing Then                 Else                     'Teeme lahtrid tühjaks, ja lõpetame                     Range(Cells(rida, veerg), Cells(rida + reakordaja - 1, veerg)).Clear                     aitab = True                     Exit For                 End If             Next veerg         Next rida         Application.ScreenUpdating = True     End If End Sub Sub eemalda_element(address As String)         Dim rida As Integer, veerg As Integer, reamuutus As Integer, veerumuutus As Integer     Dim aitab As Boolean         If Not Application.Intersect(Range(address), Range(Cells(algus_rida, algus_veerg), Cells(algus_rida + mitu_rida * reakordaja, algus_veerg + mitu_veergu))) Is Nothing Then         Application.ScreenUpdating = False         aitab = True         For rida = algus_rida To algus_rida + mitu_rida * reakordaja Step reakordaja             For veerg = algus_veerg To algus_veerg + mitu_veergu - 1                 If Not (Application.Intersect(Range(address), Range(Cells(rida, veerg), (Cells(rida + reakordaja - 1, veerg)))) Is Nothing) Then aitab = False                 If aitab = False Then                     reamuutus = Int((veerg - algus_veerg + 1) / mitu_veergu)                     veerumuutus = 1 - mitu_veergu * reamuutus                     Range(Cells(rida + reamuutus * reakordaja, veerg + veerumuutus), Cells(rida + reamuutus * reakordaja + reakordaja - 1, veerg + veerumuutus)).Cut                     Cells(rida, veerg).Select                     ActiveSheet.Paste                 End If             Next veerg         Next rida         Application.ScreenUpdating = True     End If End Sub

Eks vastavalt olukorrale ja soovidele on nõudmised funktsioonidele erinevad. Seepärast ka VBA, kirjutad juurde mis ise parasjagu tahad

[alfreedo]

Koppel.
Mitte et see enam tähtsust omaks aga Exceli Vba-s on täitsa olemas ju selline käsk nagu: Application.Undo.

Minu koodis ma seda kasutasingi: peale lahtri sisu muutmist nimelises piirkonnas kasutaja poolt, salvestatakse köigepealt uus sisestus mällu.
Seejärel käsuga Undo taastatakse lehel eelnev olukord ning loetakse nimelise piirkonna lahtritest info mällu.
Seejärel loetakse mälust info tagasi lehele ja kui jõutakse "uue sisestuse lahtri-aadressini" uus info ka sisestatakse lehele ning jätkatakse edasi vana info lugemist lehele.
Nimelist piirkonda suurendatakse ühe lahtri võrra ja thats it.

Aga jah vwg kood ehk arusaadavam ja kood loetavam.