keveyttä toimintaan

remec

Tervehdys,

Haluaisin vähän parantaa tuossa alla olevan koodi rivistön suoritus aikaa,eli kyseinen pätkä tekee sen mitä tarvitaan, mutta aikaa suorittamiseen meni n. tunti.

eli mulla on soluissa b2-b3009 asiakkaiden tunnukset vuodelta 2004. soluissa h2-h9943 mulla on vuoden 2006 asiakkaat. ja nyt haluan verrata että ketkä asiakkaista on olleet 2004 ja ovat vieläkin jäljellä =) eli alla oleva ohjelma tekee seuraavaa: jos solussa b2 oleva arvo = h2-h10000 niin kopioidaan h,i,j solut laskurin kohdata laskuri2 d,e,f soluihin.

Mutta ongelmana on tosiaan tuo hitaus mitenkäs olisko jotain nopeempaa koodia/ valista excelin komentoa tälle

Tässä vielä koodi:

Sub main()

For laskuri2 = 2 To 3010

For laskuri = 2 To 10000

If Range("b" & laskuri2) = Range("h" & laskuri) Then Range("d" & laskuri2) = Range("h" & laskuri)
If Range("b" & laskuri2) = Range("h" & laskuri) Then Range("e" & laskuri2) = Range("i" & laskuri)
If Range("b" & laskuri2) = Range("h" & laskuri) Then Range("f" & laskuri2) = Range("g" & laskuri)
Next
Next

End Sub


kiitos avustanne

7

678

Äänestä

    Vastaukset

    Anonyymi (Kirjaudu / Rekisteröidy)
    5000
    • Pasi

      Kannattaa ainakin laittaa näytön päivitys pois päältä, eli Application.ScreenUpdating = False.
      Koodin lopuksi taas päälle: Application.ScreenUpdating = True. Tämä nopeuttaa jonkin verran, minua viisaammilla voi olla oikeastikin tehokkaita konsteja mutta tämä tuli näin pikaisesti mieleen. Alla muokattu koodi:


      Sub main()

      Application.ScreenUpdating = False

      For laskuri2 = 2 To 3010

      For laskuri = 2 To 10000

      If Range("b" & laskuri2) = Range("h" & laskuri) Then Range("d" & laskuri2) = Range("h" & laskuri)
      If Range("b" & laskuri2) = Range("h" & laskuri) Then Range("e" & laskuri2) = Range("i" & laskuri)
      If Range("b" & laskuri2) = Range("h" & laskuri) Then Range("f" & laskuri2) = Range("g" & laskuri)
      Next
      Next

      Application.ScreenUpdating = True

      End Sub

      -Pasi-

    • Pasi

      Sub main()

      Application.ScreenUpdating = False
      For laskuri2 = 2 To 3010
      For laskuri = 2 To 10000
      If Range("b" & laskuri2) = Range("h" & laskuri) Then
      Range("d" & laskuri2) = Range("h" & laskuri)
      Range("e" & laskuri2) = Range("i" & laskuri)
      Range("f" & laskuri2) = Range("g" & laskuri)
      End If
      Next
      Next
      Application.ScreenUpdating = True

      End Sub

      -Pasi-

    • Sama kun yllä

      unohda nyt kuitenkin tuo edellinen... Tässä:

      Sub main()

      Application.ScreenUpdating = False
      For laskuri2 = 2 To 3010
      For laskuri = 2 To 10002 - laskuri2
      If Range("b" & laskuri2) = Range("h" & laskuri) Then
      Range("d" & laskuri2) = Range("h" & laskuri)
      Range("e" & laskuri2) = Range("i" & laskuri)
      Range("f" & laskuri2) = Range("g" & laskuri)
      End If
      Next
      Next
      Application.ScreenUpdating = True

      End Sub

    • Kunde

      En ole varma onko just sitä mitä halusit mutta räätälöimällä saat helposti muokattua

      Sub Testi()
      Dim vika As Double
      Dim vika2 As Double
      Application.ScreenUpdating = False
      vika = Range("A65536").End(xlUp).Row
      vika2 = Range("H65536").End(xlUp).Row
      Range("D4:F" & vika) = ""
      Range("D4").FormulaArray = "=IF(COUNTIF(R4C1:R20000C1,RC[4])>0,RC[4],"""")"
      Range("D4").AutoFill Destination:=Range("D4:D" & vika), Type:=xlFillDefault

      Range("E4").FormulaR1C1 = "=IF(ISNA(VLOOKUP(RC[-1],R4C8:R20000C10,2)),"""",VLOOKUP(RC[-1],R4C8:R20000C10,2))"
      Range("E4").AutoFill Destination:=Range("E4:E" & vika2), Type:=xlFillDefault

      Range("F4").FormulaR1C1 = "=IF(ISNA(VLOOKUP(RC[-2],R4C8:R20000C10,3)),"""",VLOOKUP(RC[-2],R4C8:R20000C10,3))"
      Range("F4").AutoFill Destination:=Range("F4:F" & vika2), Type:=xlFillDefault
      Range("D4:F" & vika2).Select
      Selection.Copy
      Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
      :=False, Transpose:=False
      Application.CutCopyMode = False

      Range("A1").Select
      Application.ScreenUpdating = True
      End Sub

      • Kunde

        lisäsin vielä laskenta jutun ja nyt suorittaa alle 3 sekunnin 10000 riviä tietoa, joten nopeutuminen on biturbo luokkaa...

        Sub Testi()
        Dim vika As Double
        Dim vika2 As Double
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
        vika = Range("A65536").End(xlUp).Row
        vika2 = Range("H65536").End(xlUp).Row
        Range("D4:F" & vika) = ""
        Range("D4").FormulaArray = "=IF(COUNTIF(R4C1:R20000C1,RC[4])>0,RC[4],"""")"
        Range("D4").AutoFill Destination:=Range("D4:D" & vika), Type:=xlFillDefault

        Range("E4").FormulaR1C1 = "=IF(ISNA(VLOOKUP(RC[-1],R4C8:R20000C10,2)),"""",VLOOKUP(RC[-1],R4C8:R20000C10,2))"
        Range("E4").AutoFill Destination:=Range("E4:E" & vika2), Type:=xlFillDefault

        Range("F4").FormulaR1C1 = "=IF(ISNA(VLOOKUP(RC[-2],R4C8:R20000C10,3)),"""",VLOOKUP(RC[-2],R4C8:R20000C10,3))"
        Range("F4").AutoFill Destination:=Range("F4:F" & vika2), Type:=xlFillDefault
        Range("D4:F" & vika2).Select
        Selection.Copy
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Application.CutCopyMode = False

        Range("A1").Select
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
        End Sub

      • remec
        Kunde kirjoitti:

        lisäsin vielä laskenta jutun ja nyt suorittaa alle 3 sekunnin 10000 riviä tietoa, joten nopeutuminen on biturbo luokkaa...

        Sub Testi()
        Dim vika As Double
        Dim vika2 As Double
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
        vika = Range("A65536").End(xlUp).Row
        vika2 = Range("H65536").End(xlUp).Row
        Range("D4:F" & vika) = ""
        Range("D4").FormulaArray = "=IF(COUNTIF(R4C1:R20000C1,RC[4])>0,RC[4],"""")"
        Range("D4").AutoFill Destination:=Range("D4:D" & vika), Type:=xlFillDefault

        Range("E4").FormulaR1C1 = "=IF(ISNA(VLOOKUP(RC[-1],R4C8:R20000C10,2)),"""",VLOOKUP(RC[-1],R4C8:R20000C10,2))"
        Range("E4").AutoFill Destination:=Range("E4:E" & vika2), Type:=xlFillDefault

        Range("F4").FormulaR1C1 = "=IF(ISNA(VLOOKUP(RC[-2],R4C8:R20000C10,3)),"""",VLOOKUP(RC[-2],R4C8:R20000C10,3))"
        Range("F4").AutoFill Destination:=Range("F4:F" & vika2), Type:=xlFillDefault
        Range("D4:F" & vika2).Select
        Selection.Copy
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Application.CutCopyMode = False

        Range("A1").Select
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
        End Sub

        taas nolottaa myöntää mutta modaaminen ei onnistu kun ei ymmärrä mitä koodi tekee =) muutoin aika selväää, mutta mitä tarkoittaakaan:

        Range("D4").FormulaArray = "=IF(COUNTIF(R4C1:R20000C1,RC[4])>0,RC[4],"""")"
        Range("D4").AutoFill Destination:=Range("D4:D" & vika), Type:=xlFillDefault

        en saa tuosta mitään tolkkua. jos vielä jaksamista riittää niin viititkö jeesata. loppu varmaan aukeeaa kunhan tuon saa selville.

        ---niin siis ei toiminut---

        Eli ideahan oli jos soluista b2-b:n vikasta löytyvä tieto löytyy myös solusta h2 - h:n viimoinen solu niin kopioidaan se kyseinen H solu sekä viereiset vastaavat g ja i solu, d, e, f soluihin... en enää itekkään pysy perässä

        mutta tältä se siis näyttää

        .....a.....b.....c....d....e....f....g.....h.....i
        1
        2 . ma...005...4 ... .... ..... ...pe...001.. 6
        3 . de...007...8 ... .... ..... ...ma...005.. 12
        4 . ti...102...10 .. .... ..... ...ju...006.. 35
        5 . ju...006...8 ... .... ..... ...se...008.. 5

        Eli tarkastetaan solu b2, mikäli b2 = h2-h10000 niin kopioidaan g2,h2 ja i2 kohtaan d2,e2,ja f2. tuossa esimerkissä d2 olisi siis ma . e2 olisi 005 ja f2 olisi 12. seuraavat solut olisivat tyhjiä koska vastaavaa tietoa ei löydy. vasta d5, e5 ja f5 saisivat arvon ju, 006 ja 35

        En pysy enää itsekkään perässä, toivottavasti te pysytte. kiitos avusta =)

      • Kunde
        Kunde kirjoitti:

        lisäsin vielä laskenta jutun ja nyt suorittaa alle 3 sekunnin 10000 riviä tietoa, joten nopeutuminen on biturbo luokkaa...

        Sub Testi()
        Dim vika As Double
        Dim vika2 As Double
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
        vika = Range("A65536").End(xlUp).Row
        vika2 = Range("H65536").End(xlUp).Row
        Range("D4:F" & vika) = ""
        Range("D4").FormulaArray = "=IF(COUNTIF(R4C1:R20000C1,RC[4])>0,RC[4],"""")"
        Range("D4").AutoFill Destination:=Range("D4:D" & vika), Type:=xlFillDefault

        Range("E4").FormulaR1C1 = "=IF(ISNA(VLOOKUP(RC[-1],R4C8:R20000C10,2)),"""",VLOOKUP(RC[-1],R4C8:R20000C10,2))"
        Range("E4").AutoFill Destination:=Range("E4:E" & vika2), Type:=xlFillDefault

        Range("F4").FormulaR1C1 = "=IF(ISNA(VLOOKUP(RC[-2],R4C8:R20000C10,3)),"""",VLOOKUP(RC[-2],R4C8:R20000C10,3))"
        Range("F4").AutoFill Destination:=Range("F4:F" & vika2), Type:=xlFillDefault
        Range("D4:F" & vika2).Select
        Selection.Copy
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Application.CutCopyMode = False

        Range("A1").Select
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
        End Sub

        ei ole nyt exceliä tällä koneella, joten ulkomuistista
        näkyy olevan turhia juttujakin vielä koodissa...

        Range("D4").FormulaArray = "=IF(COUNTIF(R4C1:R20000C1,RC[4])>0,RC[4],"""")"
        Range("D4").AutoFill Destination:=Range("D4:D" & vika), Type:=xlFillDefault

        tekee matriisikaavan soluun D4 ja sitten täyttää alueen D4:D vika kaavalla
        tuo kaava hakee yhteiset asiakasnumerot sarakkeen G asiakasnumeroista

        ohjelman kulku on seuraava:

        kuvaruutupäivitys pois päältä
        manuaalilaskenta päälle
        etsitään vika A-sarakkeesta
        etsitään vika H -sarakkeesta- turha
        tyhjennetään alue D4:D & vika
        tehdään matriisikaava D4 (hakee yhteiset asiakasnumerot listasta)
        kopioidaan D4;D & vika asti
        tehdää PHAKU kaava E4
        kopioidaan D4;D & vika asti -turhaan muuten toi vika2 vika riittää
        tehdää PHAKU kaava F4
        kopioidaan F4;D & vika asti turhaan muuten toi vika2 vika riittää
        tän nyt lisäsin varmuuden vuoksi,ettei vahingossa poista kaavaa...
        kopioidaan kaavat ja muutetan arvoiksi
        kuvaruutupäivitys päälle
        automaattilaskenta päälle

    Ketjusta on poistettu 0 sääntöjenvastaista viestiä.

    Takaisin ylös

    Luetuimmat keskustelut

    1. Suomalainen tutkimus paljasti oudon asian vasemmistolaisista - he häpeävät itseään

      Kyllä, asia on faktaa. Suomalainen tutkimus osoittaa, että vasemmistolaisina itseään pitävät kansalaiset häpeävät itseää
      Maailman menoa
      141
      3878

    2. Sosialismia Tampereella: Virallinen ilmiantolinja avautuu kaupungissa

      Nyt siis mennään mansessa ihan justiinsa samaan malliin kuin entisessä Neuvostoliitossa, jossa saattoi ilmiantaa naapuri
      Maailman menoa
      351
      3011

    3. Tätä et nähnyt tv:ssä: Frederik paljastaa - Totuus "haisevasta jäynästä" pehtoorille Farmilla

      Frederik veti ns. herneen nenään ja päätti kostaa pehtoorille. Mitäs mieltä olet Frederikin "aamutoimista"? Lue jutt
      Tv-sarjat
      11
      1915

    4. Ellen Jokikunnas paljastaa kyynelehtien Ralph-pojasta: "Apua..."

      Ellen Jokikunnaksen ja hänen puolisonsa Jari Raskin perheestä ja taloprojektista Italiassa kertova Unelmia Italiassa -sa
      Suomalaiset julkkikset
      9
      1635

    5. Oho! Vappu Pimiä teki "röyhkeän" teon - Onko sopivaa paljastaa tämä MasterChef-sarjasta?

      Vappu Pimiä on astunut MasterChef Suomi -keittiöön ja liittynyt ohjelman legendaariseen tuomaristoon Helena Puolakan ja
      Tv-sarjat
      4
      1099

    6. Mun kaikkialta häviäminen

      Ei liity sinuun. Muista se. ❤️ Mua kiusataan enkä mä enää jaksa.
      Ikävä
      71
      944

    7. Kaste tulisi tehdä apostolisella tavalla Ap. t. 2:38 mukaan

      Apostolit eivät kastaneet kolminaisuuden nimellä vaan Jeesuksen alkuperäisen käskyn mukaisesti: Ap. t. 2:38 Niin Pietar
      Kaste
      38
      874

    8. Onko teillä

      minkä tyyppisiä seksifantasioita kaivattunne kanssa?
      Ikävä
      44
      784

    9. Kuhmossa rallit alkoi ennen aikojaan

      Paettiin polliisia törkeästi? Se tuo rallikiima on näemmä saavuttanu paikalliset tommi mäkiset kiljupäissään auton rat
      Kuhmo
      23
      781

    10. Inhottaa ajatus siitä

      Miten monia olet pannut.
      Ikävä
      67
      769
    Aihe
    TietosuojaselosteKäyttöehdotEvästeasetuksetSäännöt