[es] - [Excel] Makro koji će kopirati oblast po kriterijumu

s.makic

Član broj: 137518
Poruke: 63
213.244.197.*

Profil

[Excel] Makro koji će kopirati oblast po kriterijumu

^{29.08.2007. u 12:54}

kako da putem makroa kopiram rang I14:N493 ali samo do reda gde je ćelija N>-0.01, zatim da to kopira u rangu od A14:F493, i ispod ubaci tekst koji se nalazi u ćeliji M2. Napomena da velićina ranga A14:F nije unapred poznata.
Unapred hvala na pomoći.

^{29.08.2007. u 12:54}

Milan Gligorijevic
student ETF-a
Pančevo

SuperModerator
Član broj: 73740
Poruke: 4303
*.dynamic.panet.co.yu.

Jabber: mmwc@elitesecurity.org

Profil

Re: [Excel] Makro koji će kopirati oblast po kriterijumu

^{29.08.2007. u 13:01}

(29.08.2007. - 15:01) Tema je premeštena iz foruma Predlozi i pitanja u forum Office.

ex. mmwc TriDeNet o 3Dnet-u
___________________
|^^^^^^^^^^^^^|____
| elitesecurity | '|";,__.
|_..._....._____===|=_|__|....,]|
"(@)'(@)****|(@)*(@)***(@)

^{29.08.2007. u 13:01}

Jpeca
Predrag Jovanović
Bozic i sinovi škola računara
Pančevo

Moderator
Član broj: 25683
Poruke: 916
212.200.27.*

Jabber: jpeca@elitesecurity.org

Profil

Re: [Excel] Makro koji će kopirati oblast po kriterijumu

^{30.08.2007. u 09:29}

Jedan (ne najoptimalniji) način je da ideš red po red u opsegu I14:N493, ispituješ da li je zadovoljen uslov i ako jeste kopiraš počevši od A14 nadole.
Kode sam razdvojio na proceduru koja kopira (da bude malo univerzalnije) i kod koji poziva ovu proceduru u tvom konkretnom slučaju

Code:

Sub MyCopy(srcRng As Range, dstRng As Range, Kriterijum As Double)
' Kopira iz zadatog opseca srcRng u odredišni opseg
' sve redove do reda u kojem je ispunjen kriterijum u poslednjoj koloni
' P. Jovanovic za elitesecurity.org
Dim r As Long
Dim rt As Long, ct As Long
Dim sht As Worksheet
Dim cl As Integer, lastcol As Integer

r = 1
rt = dstRng.Row
ct = dstRng.Column
Set sht = dstRng.Worksheet
lastcol = srcRng.Columns.Count

Do While srcRng.Cells(1, lastcol).Offset(rowOffset:=r - 1) >= Kriterijum
    For cl = 1 To lastcol  ' prenosi vrednosti iz reda
      sht.Cells(rt, ct + cl - 1).Value = srcRng.Cells(r, cl).Value
    Next cl
    r = r + 1
    rt = rt + 1
Loop

End Sub

Poziv prethodne procedure

Code:

Sub Test()
  Dim sh As Worksheet
  Set sh = ActiveSheet
  Application.ScreenUpdating = False
  MyCopy sh.Range("I14:N493"), sh.Range("A14"), -0.01
  Application.ScreenUpdating = True
  ' Prepis teksta iz M2
  sh.Range("A14").End(xlDown).Offset(rowOffset:=1).Value = sh.Range("M2").Text
End Sub

Dva u dva ide jednom ako možeš da ga ućuškaš

^{30.08.2007. u 09:29}