Excel 2007 táblázatból adatokat kiíró makró

Excel 2007 táblázatból adatokat kiíró makró
2011-07-19T15:52:49+02:00
2011-07-22T19:40:52+02:00
2022-10-26T10:15:35+02:00
  • Látom unatkoztál.

    Ez aztán száguld...

    Mutasd a teljes hozzászólást!
  • Ezt mérd le.

    Sub Nemnulla(forrlap As Worksheet, cellap As Worksheet) Dim forrsor As Long, forroszlop As Long, sor As Long, oszlop As Long Dim sorveg As Long, oszlopveg As Long, celsor As Long Dim tart As Range, vt As Variant Dim tart1 As Range, vt1 As Variant With forrlap Set tart = .Range(.Cells(2, 2), .Cells(.UsedRange.Rows.Count, .UsedRange.Columns.Count)) vt = tart.Value forrsor = LBound(vt, 1) sorveg = UBound(vt, 1) forroszlop = LBound(vt, 2) oszlopveg = UBound(vt, 2) celsor = 1 Set tart1 = cellap.Range("a1:c" & (1 + sorveg - forrsor) * (1 + oszlopveg - forroszlop)) vt1 = tart1.Value For sor = forrsor To sorveg For oszlop = forroszlop To oszlopveg If .Cells(sor + 1, 1).Value <> "" And vt(sor, oszlop) <> 0 Then vt1(celsor, 1) = .Cells(sor + 1, 1).Value vt1(celsor, 2) = oszlop vt1(celsor, 3) = vt(sor, oszlop) celsor = celsor + 1 End If Next oszlop Next sor tart1.Value = vt1 Set tart = Nothing Set tart1 = Nothing End With End Sub
    Mutasd a teljes hozzászólást!
  • ófene, mitől kerülhetett át az állás/munkarovatba?

    Robi80: igen, előfordulhat figyelmetlenségből származó hiba, majd figyelek , mindenesetre lementettem a ti kódjaitokat is!
    Mutasd a teljes hozzászólást!
  • Micu:
    Köszi a tippeket.

    monitor:
    Neked is köszi a tippeket.
    Először valami univerzális megoldáson gondolkodtam, hogy mi van ha mégsem úgy meg az oszlop számozása, azért olvasom ki, mi is van beleírva, a Cella.Column - 1 helyett... aztán így maradt.

    Dark10:
    Végeredményben úgy gondolom , ha a felhasználó adja be a kívánt tartományt, az egy nagy hibaforrás lehetősége.
    Mutasd a teljes hozzászólást!
  • cel.Cells(sor, 2).Value = .Cells(Cella.Row - .Cells(Cella.Row, 1).Value, Cella.Column).Value


    Szerintem az is sokat gyorsítana Robi80 kódján, ha ezt lecserélné pl. erre:

    cel.Cells(sor, 2).Value = Cella.Column - 1

    Mondjuk polyJoe felvetése érdekes, miszerint a ".Value" lassít-e.

    Nem vagyok benne biztos, hogy lassít, mert ez nélkül még meg kell keresni egy alapértelmezett tulajdonságot. Hasonló lehet a variant és a pontosan definiált típus problematikájához. - De lehet, hogy tévedek.
    Mutasd a teljes hozzászólást!
  • Csak néhány ötlet.

    Usedrange (első oszlopának kihagyása helyett
    Set ur = ActiveSheet.UsedRange set tartomany= ur.Offset(0, 1).Resize(ur.Rows.Count, ur.Columns.Count - 1)
    Ezen már lehet foreach (a változó azért ez, mert te is hasonló-t használsz késöbb)

    ---
    Én a lapról (adatokról) csinálnék egy másolatot, ahol első lépésben cseréltetném a 0-t ""-re. akkor máris spórolok egy if ágat, mert nem kell vizsgálni a "" és a 0 variációt is

    ---
    Monitoré azért lehet gyorsabb, mert te állandóan az Exceltől kéregeted a sor és oszlop értékeket, nála meg ez a VBA változóában van.

    ===
    Dark10: Azért nincs pontadás, mert már az állás/munka rovatban van.
    Mutasd a teljes hozzászólást!
  • Sziasztok!

    Köszönöm a kódokat, kipróbáltam mindet,jók hála értük !

    Nekem Delila_1 kódjában az tetszik, hogy külön megadhatom a tartományt neki, habár Robi80 és monitor kódjában meg éppen ennek ellenkezője a jó: hogy ott meg az egész oldalt megcsinálja, ahogy észrevettem. A használat fogja eldönteni, hogy melyiket célszerű használni, majd kiderül.

    Nagyban megkönnyítettétek a munkámat, köszönöm! Nem tudom, hogy létezik-e még ilyen pontadás és hogyan lehet azt megcsinálni, eddig megjelent, de ma már nem látom a hsz-ek alatt az "elfogadom megoldásnak" írást, vagy csak figyelmetlen vagyok? Tudtok még ebben segíteni? Delila_1-nek adnám a pontot, az ő kódja állt elsőnek legközelebb a problémám megoldásához .

    Én sztech szakot végeztem, habár nem programozóit, volt programozás-kurzusainkon szó az algoritmusok számolás-igényéről és idejükről. Azt nagyon belénkverték, hogy célszerű figyelni erre, mert nagy munka esetén igen sokat jelent. Tök jó, hogy Ti is igyekeztek minél jobban optimalizálni a kódsorokat!

    Csatolom már 97-2003-as változatban is a táblázatot, ha más olvasó is kipróbálná, de csak így tudja.
    Mutasd a teljes hozzászólást!
    Csatolt állomány
  • Ezt bárki kipróbálhatja:

    Public Declare Function QueryPerformanceCounter Lib "Kernel32" (X As Currency) As Boolean Public Declare Function QueryPerformanceFrequency Lib "Kernel32" (X As Currency) As Boolean Sub Gyorsasagteszt() Dim monitorkezdo As Currency, monitorveg As Currency Dim Robi80kezdo As Currency, Robi80veg As Currency Dim Robi80ido As Currency, monitorido As Currency Dim Freq As Currency QueryPerformanceFrequency Freq ActiveWorkbook.Worksheets(2).Cells.ClearContents With ActiveWorkbook.Worksheets(1) Dim i0 As Long For i0 = 2 To 1000 .Cells(i0, 1) = i0 - 1 Next i0 For i0 = 2 To 50 .Cells(1, i0) = i0 - 1 Next i0 .Range(Cells(1, 2), Cells(1, 50)).Copy Destination:=.Range(Cells(2, 2), Cells(1000, 50)) 'monitor MsgBox "monitor kezd" QueryPerformanceCounter monitorkezdo Proba QueryPerformanceCounter monitorveg ActiveWorkbook.Worksheets(2).Cells.ClearContents MsgBox "Robi80 folytat" QueryPerformanceCounter Robi80kezdo program QueryPerformanceCounter Robi80veg monitorido = (monitorveg - monitorkezdo) / Freq Robi80ido = (Robi80veg - Robi80kezdo) / Freq Dim kulonbseg As Currency kulonbseg = Robi80ido - monitorido .Cells.ClearContents ActiveWorkbook.Worksheets(2).Cells.ClearContents .Cells(1, 1) = "Robi80:" .Cells(1, 2) = Replace(Format$(Robi80ido, "0.0000"), ",", ".") .Cells(2, 1) = "monitor:" .Cells(2, 2) = Replace(Format$(monitorido, "0.0000"), ",", ".") .Cells(3, 2) = Replace(Format$(kulonbseg, "0.0000"), ",", ".") If kulonbseg = 0 Then .Cells(3, 1) = "Döntetlen" MsgBox "Döntetlen" ElseIf kulonbseg > 0 Then .Cells(3, 1) = "monitor nyert" MsgBox "monitor nyert" Else .Cells(3, 1) = "Robi80 nyert" MsgBox "Robi80 nyert" End If End With End Sub Sub program() Call nullat_keres(Worksheets("Munka1"), Worksheets("Munka2")) End Sub Sub nullat_keres(ByVal forras As Worksheet, ByVal cel As Worksheet) Dim tartomany As Range Dim Cella As Range Dim sor As Long sor = 0 With forras Set tartomany = Range(.Cells(2, 2), .Cells(.UsedRange.Rows.Count, .UsedRange.Columns.Count)) For Each Cella In tartomany If .Cells(Cella.Row, 1).Value <> "" And Cella.Value <> 0 Then sor = sor + 1 cel.Cells(sor, 1).Value = .Cells(Cella.Row, 1).Value cel.Cells(sor, 2).Value = .Cells(Cella.Row - .Cells(Cella.Row, 1).Value, Cella.Column).Value cel.Cells(sor, 3).Value = Cella.Value End If Next Cella End With End Sub Sub Proba() Nemnulla ActiveWorkbook.Worksheets(1), ActiveWorkbook.Worksheets(2) End Sub Sub Nemnulla(forrlap As Worksheet, cellap As Worksheet) Dim forrsor As Long, forroszlop As Long Dim sorveg As Long, oszlopveg As Long, celsor As Long celsor = 1 With forrlap sorveg = .UsedRange(.UsedRange.Count).Row oszlopveg = .UsedRange(.UsedRange.Count).Column For forrsor = 2 To sorveg For forroszlop = 2 To oszlopveg If .Cells(forrsor, 1).Value <> "" And .Cells(forrsor, forroszlop).Value <> 0 Then cellap.Cells(celsor, 1) = .Cells(forrsor, 1).Value cellap.Cells(celsor, 2) = forroszlop - 1 cellap.Cells(celsor, 3) = .Cells(forrsor, forroszlop).Value celsor = celsor + 1 End If Next forroszlop Next forrsor End With End Sub
    Mutasd a teljes hozzászólást!
  • Ha mindig lehet tudni, hogy a sor és az oszlop sorszáma azonos a pozícióval, azzal sokat lehet gyorsítani. Valamint ha lehetne tudni, hogy a táblázatoknak csak a jobb felső háromszöge van kitöltve, azzal a legtöbbet! Amúgy szvsz a sok .Value nem kell (bár nem tudom, ez számottevően gyorsít-e ), de az biztosan gyorsít, ha a többször is használt Cella.Row értékét egy változóba kiteszitek. És végül, mivel az eredeti kérdésben
    ha talál 0-tól különböző számot
    szerepel, az IsNumeric() függvényt használnám <>"" helyett (bár ez asszem inkább lassít, mint gyorsít).
    Mutasd a teljes hozzászólást!
  • Lehet 2, egymásba ágyazott For ciklusnál már nem....

    Mert a többi kódrészben nincs lényegi eltérés a két program között...

    Ha meg szerinted pontatlan is a mérés, akkor mind a két programnál pontatlan... akárhányszor is mérem, az enyém mindig előbb lefut ... de mérd le te is...
    De mondjuk ezen kár turbózni magunkat (igaz nem is én jöttem azzal először, hogy kié a gyorsabb)

    Mutasd a teljes hozzászólást!
  • A pontos mérés lenne ugyebár mindennek az alapja.

    A for eleve gyorsabb, mint a for each.
    Mutasd a teljes hozzászólást!
  • Lemértem a futási időt a két utolsó program verziónk között.

    az enyém:
    0,015625 s

    monitoré:
    0,03125 s

    Fele annyi idő alatt lefut.

    Megnéztem még a korábbi verziómat is, ahol benne volt a plusz feltétel és a tartomány az egész usedrange volt.
    Még az is előbb lefut:
    0,0234375 s



    Mutasd a teljes hozzászólást!
  • Továbbra is azt mondom, hogy a for each-t ennél a feladatnál mellőzni kellene, mert amint láthatod, így nem szükséges a következő ellenőrzés:

    If Cella.Column > 1


    Ez a feltétel nem közvetlenül a For Each miatta van, hanem a UsedRange miatt.
    Ha most nem a UsedRange-val határozom meg a kívánt tartományt, akkor tényleg nem fog kelleni az a feltétel sem.

    Javítottam is.
    Így más optimálisabb a programom is. Persze lehet lassabb még mindig, mint a tiéd, nem teszteltem.


    Sub program() Call nullat_keres(Worksheets("Munka1"), Worksheets("Munka3")) End Sub Sub nullat_keres(ByVal forras As Worksheet, ByVal cel As Worksheet) Dim tartomany As Range Dim Cella As Range Dim sor As Long sor = 0 With forras Set tartomany = Range(.Cells(2, 2), .Cells(.UsedRange.Rows.Count, .UsedRange.Columns.Count)) For Each Cella In tartomany If .Cells(Cella.Row, 1).Value <> "" And Cella.Value <> 0 Then sor = sor + 1 cel.Cells(sor, 1).Value = .Cells(Cella.Row, 1).Value cel.Cells(sor, 2).Value = .Cells(Cella.Row - .Cells(Cella.Row, 1).Value, Cella.Column).Value cel.Cells(sor, 3).Value = Cella.Value End If Next Cella End With End Sub

    Mutasd a teljes hozzászólást!
  • Sikerült megnyitnom a fájlokat, most már látom a problémát.
    Mondjuk olyan nagyon sokat nem kellett rajt módosítanom.
    Gyakorlatilag csak az Usedrange-re kellett kiegészíteni.

    Továbbra is azt mondom, hogy a for each-t ennél a feladatnál mellőzni kellene, mert amint láthatod, így nem szükséges a következő ellenőrzés:

    If Cella.Column > 1


    Arról nem is beszélve, hogy így gyorsabb is , ezért 2 szempontból is optimálisabb a sima for ciklus. Egyetlen hátránya, hogy a forráskód összetettebb.

    Sub Proba() Nemnulla ActiveWorkbook.Worksheets(1), ActiveWorkbook.Worksheets(2) End Sub Sub Nemnulla(forrlap As Worksheet, cellap As Worksheet) Dim forrsor As Long, forroszlop As Long Dim sorveg As Long, oszlopveg As Long, celsor As Long celsor = 1 With forrlap sorveg = .UsedRange(.UsedRange.Count).Row oszlopveg = .UsedRange(.UsedRange.Count).Column For forrsor = 2 To sorveg For forroszlop = 2 To oszlopveg If .Cells(forrsor, 1).Value <> "" And .Cells(forrsor, forroszlop).Value <> 0 Then cellap.Cells(celsor, 1) = .Cells(forrsor, 1).Value cellap.Cells(celsor, 2) = forroszlop - 1 cellap.Cells(celsor, 3) = .Cells(forrsor, forroszlop).Value celsor = celsor + 1 End If Next forroszlop Next forrsor End With End Sub
    Mutasd a teljes hozzászólást!
  • Elhiszem, mert csak holnap délelőtt leszek olyan gép előtt, amivel meg tudom nyitni a fájlt. Addig pontosan nem tudom, hogy helyezkednek el a táblázatok, optimalizálni addig esélyem sincs...
    Mutasd a teljes hozzászólást!
  • Hát igen, egy kis optimalizáció ráférne, ebben igazad van.


    Nálad viszont valami nem oké.
    A 2. és 3. táblázat részt már nem jól számolja mert a sor és oszlopindexeket is beleveszi a vizsgálatba (aposztróffal és anélkül is). Az oszlopveg-et is újra kellene számolnia a 2. és 3. résznél.

    Ennek kellene kijönnie:

    1 2 6 1 3 9 1 4 12 1 5 15 1 6 18 2 3 3 2 4 1 2 5 3 10 11 33 2 9 1 2 10 1 3 8 1 3 11 1 10 11 33 10 12 36 11 12 2 8 15 2 9 14 4
    Mutasd a teljes hozzászólást!
  • Valahogy így oldanám meg:

    Sub Proba() Nemnulla ActiveWorkbook.Worksheets(1), ActiveWorkbook.Worksheets(2) End Sub Sub Nemnulla(forrlap As Worksheet, cellap As Worksheet) Dim forrsor As Long, forroszlop As Long Dim sorveg As Long, oszlopveg As Long, celsor As Long celsor = 1 With forrlap sorveg = .Cells(Rows.Count, 1).End(xlUp).Row oszlopveg = .Cells(1, Columns.Count).End(xlToLeft).Column For forrsor = 2 To sorveg For forroszlop = 2 To oszlopveg If .Cells(forrsor, forroszlop).Value <> 0 Then cellap.Cells(celsor, 1) = forrsor - 1 '.cells(forrsor,1).value cellap.Cells(celsor, 2) = forroszlop - 1 '.Cells(1, forroszlop).value cellap.Cells(celsor, 3) = .Cells(forrsor, forroszlop).Value celsor = celsor + 1 End If Next forroszlop Next forrsor End With End Sub

    Itt amik az aposztrófok után vannak, azokat akkor kell használni, ha ténylegesen a fejlécek értékére van szükség kiírásnál.

    ----

    @Robi80: Ebben a formában nem használnám a for each-t. Ennyi feltétetelt megvizsgálni akár 40000-szer???
    Mutasd a teljes hozzászólást!
  • javítva, kimaradt egy pont (With miatt kellet volna pedig), amiatt ha nem az volt az Activesheet, nem csinált semmit...


    Sub program() Call nullat_keres(Worksheets("Munka1"), Worksheets("Munka2")) End Sub Sub nullat_keres(ByVal forras As Worksheet, ByVal cel As Worksheet) Dim Cella As Range Dim sor As Long sor = 0 For Each Cella In forras.UsedRange With forras If Cella.Column > 1 And .Cells(Cella.Row, 1).Value <> "" And Cella.Value <> 0 Then sor = sor + 1 cel.Cells(sor, 1).Value = .Cells(Cella.Row, 1).Value cel.Cells(sor, 2).Value = .Cells(Cella.Row - .Cells(Cella.Row, 1).Value, Cella.Column).Value cel.Cells(sor, 3).Value = Cella.Value End If End With Next Cella End Sub
    Mutasd a teljes hozzászólást!
  • Esetleg így:


    Sub program() Call nullat_keres(Worksheets("Munka1"), Worksheets("Munka2")) End Sub Sub nullat_keres(ByVal forras As Worksheet, ByVal cel As Worksheet) Dim Cella As Range Dim sor As Long sor = 0 forras.Activate 'ha ezt nem teszem bele, és a munka2-ön állok, akkor nem csinálja meg...ezt még nyomozom For Each Cella In forras.UsedRange With forras If Cella.Column > 1 And Cells(Cella.Row, 1).Value <> "" And Cella.Value <> 0 Then sor = sor + 1 cel.Cells(sor, 1).Value = .Cells(Cella.Row, 1).Value cel.Cells(sor, 2).Value = .Cells(Cella.Row - .Cells(Cella.Row, 1).Value, Cella.Column).Value cel.Cells(sor, 3).Value = Cella.Value End If End With Next Cella End Sub
    Mutasd a teljes hozzászólást!
  • Feltételezem, hogy a táblázataid egymás alatt, az A:L oszlopokban vannak
    (az oszlopszámmal nincs baj, 1-t levonok az aktuális értékből és már jó minden esetben).


    A terület kijelölésénél hagyd ki a címsort és -oszlopot.

    Micu javaslatait figyelembe véve, és módosítva a sorszámokat:

    Sub nemnulla() Dim ter As Range, sor As Long, Cella As Range Sheets(1).Select Set ter = Application.InputBox(prompt:="Kérem a tartományt", Type:=8) sor = Sheets(2).Range("A1048576").End(xlUp).Row + 1 For Each Cella In ter If Cella <> 0 Then With Sheets(2) .Cells(sor, 1) = Cells(Cella.Row, "A") .Cells(sor, 2) = Cella.Column - 1 .Cells(sor, 3) = Cella.Value End With sor = sor + 1 End If Next End Sub
    Mutasd a teljes hozzászólást!
  • Üres füzetet tettél ki.
    Mutasd a teljes hozzászólást!
  • Köszönöm a kiigazításokat.
    Mutasd a teljes hozzászólást!
  • köszönöm a gyors reagálásokat és kódokat Nektek!
    Delila_1 kódja az, ami majdnem azt csinálja, amit elképzeltem: itt még annyit kellene módosítani, hogy ne az excel adott sorának/oszlopának a számát adja vissza, hanem a táblázat adott sorának és oszlopának a számozását. Mondjuk az oszlopszámmal nincs baj, 1-t levonok az aktuális értékből és már jó minden esetben, de a sorral nem tudom ezt megtenni. Kicsit megváltoztattam a példa xls-t, tettem bele 2, kibővített táblázatot, ezeken ha kipróbáljátok, akkor látni fogjátok mire gondoltam. (pl. 3. táblázat esetén már 30< számokat ír, holott a táblázatban 1-15 ig vannak a sorok). Ezt még meg tudjátok csinálni?

    Mutasd a teljes hozzászólást!
    Csatolt állomány
  • Azért így 2011-ben már ne sor%, hanem legalább
    sor as integer

    Bár elgondolkodok azon, hogy a 60000 sorszám biztos bele fog-e férni integer-be (%-ba)

    Elég csúnya a
    sor% = sor% + 1
    .Cells(sor, 1) =...
    használat


    A 60000-el kapcsolatban még egy gondolat, hogy miért is annyi?
    kérnék excel 2007-ben egy

    Hány sora is van a 2007-es Excelnek?
    (persze láttam:
    "akár 200*200 nagyságú"
    )


    És csak így TIT alapon:
    A "Cella" változó miért nem range?

    Mutasd a teljes hozzászólást!
  • Egy másik változat, ami bekéri a tartományt (egérrel is kijelölheted), majd a 2. lapra írja a 0-tól eltérő cellák sorát, oszlopát, és értékét.


    Sub nemnulla() Dim ter As Range, sor%, Cella As Object Sheets(1).Select Set ter = Application.InputBox(prompt:="Kérem a tartományt", Type:=8) sor% = Sheets(2).Range("A60000").End(xlUp).Row + 1 For Each Cella In ter If Cella <> 0 Then With Sheets(2) .Cells(sor, 1) = Cella.Row .Cells(sor, 2) = Cella.Column .Cells(sor, 3) = Cella End With sor% = sor% + 1 End If Next End Sub

    Újabb terület kiválasztásakor folytatja a 2. lapon az adatok kiírását.
    Mutasd a teljes hozzászólást!
  • Ezt lehet sokféleképpen megcsinálni, variálni pl:

    Itt csak a munkafüzeteket adjuk át, a tartomány majd a használt terület (usedrange) lesz.

    Call nullat_keres(Worksheets("Munka1"), Worksheets("Munka2")) ... Sub nullat_keres(ByVal forras As Worksheet, ByVal cel As Worksheet) ... For Each Cella In forras.UsedRange

    ha meg nálad az első sor illetve az első oszlop a sor - és oszlopindexek tárolására van, akkor majd bonyolíthatod azzal, hogy a sor (Cella.Row) és oszlop (Cella.Column) értékekből kivonsz egyet.. csak akkor a tartományban nem szabad ezeket az oszlopokat figyelembe venni (erre is lehet több megoldás).
    Mutasd a teljes hozzászólást!
  • Kb ilyen lenne ez:

    Module1-be:

    Sub program() Call nullat_keres(Worksheets("Munka1").Range("A1:L12"), Worksheets("Munka2")) End Sub Sub nullat_keres(ByVal forras As Range, ByVal cel As Worksheet) Dim Cella As Range Dim sor As Long sor = 0 For Each Cella In forras If Cella.Value <> 0 Then sor = sor + 1 cel.Cells(sor, 1).Value = Cella.Row & " " & Cella.Column & " " & Cella.Value End If Next Cella End Sub
    Mutasd a teljes hozzászólást!
  • Sziasztok!

    Segítséget kérnék excel 2007-ben egy konkrét makróíráshoz! VB-t egyáltalán nem ismerem és nincs időm elmélyedni benne (a többi programozás nyelv sem nagyon megy), viszont kellene egy olyan makró, ami az általam csatolt excel táblájának minden celláján végigmegy, és ha talál 0-tól különböző számot, akkor annak a cellának a TÁBLÁZATBELI sor és oszlopszámát leírja egymás mellé pl. egy másik munkalapra, ill. ezek után a cella adott értékét is. A következő 0-tól különböző számmal rendelkező cellát hasonlóképp, a következő sorba írja ki.
    Ill. a munkalapon több táblázat is lesz egymás alatt, esetleg lehet olyan makrót írni, ami az általam megadott értéktartományban csinálja ezt meg?

    Valahogy így pl. a táblázatomból:
    (táblázat adott sorának száma / táblázat adott oszlopának száma / cella értéke)
    1 2 6
    1 3 9
    1 4 12
    1 5 15
    1 6 18
    2 3 3
    2 4 1
    ...stb.

    Azért kellene nagyon ez a makró nekem, mert van vagy 40 táblázatom, amik között előfordul sok, akár 200*200 nagyságú is, amit ha végignéznék, behülyülnék szerintem

    Rem. érthetően írtam le a problémámat, kösz előre is a segítséget!
    Mutasd a teljes hozzászólást!
    Csatolt állomány
Tetszett amit olvastál? Szeretnél a jövőben is értesülni a hasonló érdekességekről?
abcd