Osaisitko auttaa ?

VBA ?

Taulukon A sarakkeessa tuotteiden nimiä, jotka esiintyvät taulukossa useampaan kertaan, Nimiä on useita satoja erilaisia, ja kukin esiintyy siis useamman kerran. Taulukon D sarakkeessa on kunkin tuotteen nimen kohdalla luku (tilausmäärä) joka on välillä 0-1000. Nyt pitäisi saada kunkin tuotteen nimen yhteenlaskettu määrä laskettua, olipa tuotteiden nimet missä kohdin tahansa taulukon A saraketta, a tehtyä erillinen lista jossa on tuotteiden nimet toisessa sarakkeessa ja yhteenlaskettu määrä kullekin tuotteelle toisessa.

Eli jos vaikkapa taulukon riveillä 8, 27, 55, ja 77 lukee A sarakkeessa tuote1 ja kunkin kohdalla D sarakkeessa on eri tai sama luku, ne pitäisi saada laskettua yhteen ja tehtyä niistä 1 rivi erilliseen taulukkoon jossa tuotteen nimi on toisessa sarakkeessa ja yhteenlaskettumäärä toisessa.

Ettei olisi liian helppoa, eri tuotteiden lukumäärä ei ole vakio.

22

147

Vastaukset

  • moduuliin...

    Option Explicit

    Sub SummaaTuotteeet()
    Dim Vika As Integer
    Dim Solu As Range
    Dim EiTuplat As New Collection
    Dim i As Integer
    Dim j As Integer
    Dim Löydetty As Double
    On Error Resume Next

    Worksheets("Sheet2").Activate
    Range("A:B") = ""
    Range("A1") = "Tuote"
    Range("B1") = "Summa"

    Worksheets("Sheet1").Activate
    Vika = Range("A65536").End(xlUp).Row
    For Each Solu In Range("A1:A" & Vika)
    EiTuplat.Add Solu.Value, CStr(Solu.Value)
    Next Solu
    On Error GoTo 0
    For i = 1 To EiTuplat.Count
    Worksheets("Sheet2").Range("A65536").End(xlUp).Offset(1, 0) = EiTuplat(i)
    Next
    Vika = Worksheets("Sheet2").Range("A65536").End(xlUp).Row
    For Each Solu In Worksheets("Sheet2").Range("A2:A" & Vika)
    Solu.Offset(0, 1) = HaeArvot(Solu, Worksheets("Sheet1").Range("A:A"))
    Next Solu
    End Sub

    Function HaeArvot(Hakuehto As Variant, HakuAlue As Range) As Double
    Dim Solu As Range
    Dim Ekaosoite As String
    With HakuAlue
    Set Solu = .Find(What:=Hakuehto)
    If Not Solu Is Nothing Then
    Ekaosoite = Solu.Address
    Do
    HaeArvot = HaeArvot Solu.Offset(0, 3).Value
    Set Solu = .FindNext(Solu)
    Loop While Not Solu Is Nothing And Solu.Address Ekaosoite
    End If
    End With

    End Function

    Keep EXCELing
    @Kunde

    • Moi. Vein tuon moduuliin. Sain viestin "subscript out of range" ja kaikki tiedot taulukosta hävisivät ???? Tarkoitus olisi että jos taulukko on välilehdellä 1, välilehdelle 2 tulisi kooste jossa näkyisi kunkin tuotteen nimi kerran ja tuotteen nimen kohdalla eri sarakkeessa yhteismäärä haettuna koko taulukon 1 välilehden niiltä kohdin joissa tuotenimen kohdalla on sarakkeessa D jokin luku. Alkuperäiset tiedot eivät saisi silti hävitä.


    • VBA ? kirjoitti:

      Moi. Vein tuon moduuliin. Sain viestin "subscript out of range" ja kaikki tiedot taulukosta hävisivät ???? Tarkoitus olisi että jos taulukko on välilehdellä 1, välilehdelle 2 tulisi kooste jossa näkyisi kunkin tuotteen nimi kerran ja tuotteen nimen kohdalla eri sarakkeessa yhteismäärä haettuna koko taulukon 1 välilehden niiltä kohdin joissa tuotenimen kohdalla on sarakkeessa D jokin luku. Alkuperäiset tiedot eivät saisi silti hävitä.

      Vaihdoitko taulukoiden nimet Sheet1 ja Sheet2 oikeiksi?


    • ... kirjoitti:

      Vaihdoitko taulukoiden nimet Sheet1 ja Sheet2 oikeiksi?

      Vaihdoin kyllä, tosin viestisi jälkeen. Nyt teki välilehdelle 2 otsikot ; a;sarakkeeseen "tuote" ja b sarakkeeseen "summa". Silti ei tuonut tuotteiden nimiä a sarakkeeseen, eikä kokonaismäärää b sarakkeeseen. Alkutilanne siis se että A sarakkeessa on tuotteiden koodit (numeroita, väliviivoja jne) jotka esiintyvät taulukosssa useilla eri riveillä. D sarakkeessa on tilausmäärä, joka siis tulisi laskea yhteen aina kun A sarakkeessa oleva tuotekoodi on sama. Näitä tuotekoodeja on tosi paljon ja ne pitäisi saada listattua välilehdelle 2 (sheet2) alekkain sarakkeeseen A ja B sarakkeeseen kunkin tuotekoodin kohdalle yhteenlaskettu määrä koko taulukosta (siis sheet1 välilehdeltä)


    • ... kirjoitti:

      Vaihdoitko taulukoiden nimet Sheet1 ja Sheet2 oikeiksi?

      Hei. Nyt alkoi toimimaan, en tiedä mitä tein, huh , huh. Onkohan tuohon vielä liitettävissä sellainen optio että toisi "sheet1" n C sarakkeesta yksikköhinnan kullekin tuotteelle. Kullakin tuotekoodilla on eri hinta mutta yksittäisillä koodeilla on kuitenkin aina sama hinta. Kiitos kaikesta avusta tähän asti :)


    • VBA ? kirjoitti:

      Hei. Nyt alkoi toimimaan, en tiedä mitä tein, huh , huh. Onkohan tuohon vielä liitettävissä sellainen optio että toisi "sheet1" n C sarakkeesta yksikköhinnan kullekin tuotteelle. Kullakin tuotekoodilla on eri hinta mutta yksittäisillä koodeilla on kuitenkin aina sama hinta. Kiitos kaikesta avusta tähän asti :)

      Option Explicit

      Sub SummaaTuotteeet()
      Dim Vika As Integer
      Dim Solu As Range
      Dim EiTuplat As New Collection
      Dim i As Integer
      Dim j As Integer
      Dim Löydetty As Double
      On Error Resume Next

      Worksheets("Sheet2").Activate
      Range("A:C") = ""
      Range("A1") = "Tuote"
      Range("B1") = "Yksikköhinta"
      Range("C1") = "Summa"

      Worksheets("Sheet1").Activate
      Vika = Range("A65536").End(xlUp).Row
      For Each Solu In Range("A1:A" & Vika)
      EiTuplat.Add Solu.Value, CStr(Solu.Value)
      Next Solu

      On Error GoTo 0

      For i = 1 To EiTuplat.Count
      Worksheets("Sheet2").Range("A65536").End(xlUp).Offset(1, 0) = EiTuplat(i)
      Next

      Vika = Worksheets("Sheet2").Range("A65536").End(xlUp).Row
      For Each Solu In Worksheets("Sheet2").Range("A2:A" & Vika)
      Solu.Offset(0, 1) = HaeArvot2(Solu, Worksheets("Sheet1").Range("A:A"))
      Solu.Offset(0, 2) = HaeArvot(Solu, Worksheets("Sheet1").Range("A:A"))
      Next Solu
      Worksheets("Sheet2").Columns("A:C").AutoFit
      End Sub

      Function HaeArvot(Hakuehto As Variant, HakuAlue As Range) As Double
      Dim Solu As Range
      Dim Ekaosoite As String
      With HakuAlue
      Set Solu = .Find(What:=Hakuehto)
      If Not Solu Is Nothing Then
      Ekaosoite = Solu.Address
      Do
      HaeArvot = HaeArvot Solu.Offset(0, 3).Value
      Set Solu = .FindNext(Solu)
      Loop While Not Solu Is Nothing And Solu.Address Ekaosoite
      End If
      End With

      End Function
      Function HaeArvot2(Hakuehto As Variant, HakuAlue As Range) As Range
      Dim Solu As Range
      Dim Ekaosoite As String
      With HakuAlue
      Set Solu = .Find(What:=Hakuehto)
      If Not Solu Is Nothing Then
      Ekaosoite = Solu.Address
      Do
      Set HaeArvot2 = Solu.Offset(0, 2)
      Set Solu = .FindNext(Solu)
      Loop While Not Solu Is Nothing And Solu.Address Ekaosoite
      End If
      End With

      End Function

      Keep EXCELing
      @Kunde


    • Kundepuu kirjoitti:

      Option Explicit

      Sub SummaaTuotteeet()
      Dim Vika As Integer
      Dim Solu As Range
      Dim EiTuplat As New Collection
      Dim i As Integer
      Dim j As Integer
      Dim Löydetty As Double
      On Error Resume Next

      Worksheets("Sheet2").Activate
      Range("A:C") = ""
      Range("A1") = "Tuote"
      Range("B1") = "Yksikköhinta"
      Range("C1") = "Summa"

      Worksheets("Sheet1").Activate
      Vika = Range("A65536").End(xlUp).Row
      For Each Solu In Range("A1:A" & Vika)
      EiTuplat.Add Solu.Value, CStr(Solu.Value)
      Next Solu

      On Error GoTo 0

      For i = 1 To EiTuplat.Count
      Worksheets("Sheet2").Range("A65536").End(xlUp).Offset(1, 0) = EiTuplat(i)
      Next

      Vika = Worksheets("Sheet2").Range("A65536").End(xlUp).Row
      For Each Solu In Worksheets("Sheet2").Range("A2:A" & Vika)
      Solu.Offset(0, 1) = HaeArvot2(Solu, Worksheets("Sheet1").Range("A:A"))
      Solu.Offset(0, 2) = HaeArvot(Solu, Worksheets("Sheet1").Range("A:A"))
      Next Solu
      Worksheets("Sheet2").Columns("A:C").AutoFit
      End Sub

      Function HaeArvot(Hakuehto As Variant, HakuAlue As Range) As Double
      Dim Solu As Range
      Dim Ekaosoite As String
      With HakuAlue
      Set Solu = .Find(What:=Hakuehto)
      If Not Solu Is Nothing Then
      Ekaosoite = Solu.Address
      Do
      HaeArvot = HaeArvot Solu.Offset(0, 3).Value
      Set Solu = .FindNext(Solu)
      Loop While Not Solu Is Nothing And Solu.Address Ekaosoite
      End If
      End With

      End Function
      Function HaeArvot2(Hakuehto As Variant, HakuAlue As Range) As Range
      Dim Solu As Range
      Dim Ekaosoite As String
      With HakuAlue
      Set Solu = .Find(What:=Hakuehto)
      If Not Solu Is Nothing Then
      Ekaosoite = Solu.Address
      Do
      Set HaeArvot2 = Solu.Offset(0, 2)
      Set Solu = .FindNext(Solu)
      Loop While Not Solu Is Nothing And Solu.Address Ekaosoite
      End If
      End With

      End Function

      Keep EXCELing
      @Kunde

      Kiitos Kunde. Jos vain kerkiät niin voisitko kertoa minulle mikä osio tuossa makrossa (onko oikea nimitys sille ?) hakee tiedon mistäkin ? Aivan vain mielenkiinnosta jos joskus oppisi tuota vba:ta käyttämään. Kiitos paljon tähän astisesta avusta.


    • VBA ? kirjoitti:

      Kiitos Kunde. Jos vain kerkiät niin voisitko kertoa minulle mikä osio tuossa makrossa (onko oikea nimitys sille ?) hakee tiedon mistäkin ? Aivan vain mielenkiinnosta jos joskus oppisi tuota vba:ta käyttämään. Kiitos paljon tähän astisesta avusta.

      Option Explicit

      Sub SummaaTuotteeet()
      Dim Vika As Integer
      Dim Solu As Range
      Dim EiTuplat As New Collection
      Dim i As Integer
      Dim j As Integer
      Dim Löydetty As Double
      On Error Resume Next
      'aktivoidaan Sheet2
      Worksheets("Sheet2").Activate
      'tyhjennetään sarakkeet A-C
      Range("A:C") = ""
      'lisätään Tuote teksti A1
      Range("A1") = "Tuote"
      'lisätään Yksikkätuote teksti B1
      Range("B1") = "Yksikköhinta"
      'lisätään Summa teksti B1
      Range("C1") = "Summa"

      ''aktivoidaan Sheet1
      Worksheets("Sheet1").Activate
      'haetaan A-sarakkeen käytössäoleva vika rivi
      Vika = Range("A65536").End(xlUp).Row
      'luupataan alue A sarakkeen alue läpi ja lisätään kokoelmaan
      'koska alussa oli On Error resume Next, niin ohjelma jatkaa toimintaasta , vaikka virhe tulisikin...
      ' ja virheitä tuleekin, koska kokoelmaan ei voi lisätä tupla arvoja ja tämä virhetarkastelua käytin tässä apuna ;-)
      For Each Solu In Range("A1:A" & Vika)
      EiTuplat.Add Solu.Value, CStr(Solu.Value)
      Next Solu
      'poistetaan virheenkäsittely
      On Error GoTo 0
      'lisätään uniikit tuotenimet A-sarakkeen ekalle tyhjälle riville
      For i = 1 To EiTuplat.Count
      Worksheets("Sheet2").Range("A65536").End(xlUp).Offset(1, 0) = EiTuplat(i)
      Next
      'haetaan vika rivi tuotenimistä
      Vika = Worksheets("Sheet2").Range("A65536").End(xlUp).Row
      'luupataan tuotenimet läpi
      For Each Solu In Worksheets("Sheet2").Range("A2:A" & Vika)
      'haetaan yksikköhinta tuotenimelle
      Solu.Offset(0, 1) = HaeArvot2(Solu, Worksheets("Sheet1").Range("A:A"))
      'haetaan summattu arvo tuotenimelle
      Solu.Offset(0, 2) = HaeArvot(Solu, Worksheets("Sheet1").Range("A:A"))
      Next Solu
      'tasataan sarakeleveydet pisimmän tekstin mukaan
      Worksheets("Sheet2").Columns("A:C").AutoFit
      End Sub

      Function HaeArvot(Hakuehto As Variant, HakuAlue As Range) As Double
      Dim Solu As Range
      Dim Ekaosoite As String
      'vastaa Excelin omaa etsi funktiota, tosin tässä funktiossa määrittelin palautusarvoksi Double (Excelin omassa Range)...
      With HakuAlue
      Set Solu = .Find(What:=Hakuehto)
      If Not Solu Is Nothing Then
      'tallenetaan muuttujaan eka löydetty solun osoite
      Ekaosoite = Solu.Address
      'luupataan niin kauan kunnes, löydetyn solun osoite eri kuin eka löydetty solun osoite
      Do
      'summataan löydetyt summat- Solu.Offset(0, 3).Value=D -sarakkeen arvot
      HaeArvot = HaeArvot Solu.Offset(0, 3).Value
      Set Solu = .FindNext(Solu)
      Loop While Not Solu Is Nothing And Solu.Address Ekaosoite
      End If
      End With

      End Function
      Function HaeArvot2(Hakuehto As Variant, HakuAlue As Range) As Range
      Dim Solu As Range
      Dim Ekaosoite As String
      'nyt funktio palauttaa Rangen -Solu.Offset(0, 2)= C-sarake
      'en jaksanut alkaa muuttelemaaan, joten tää oikeesti palauttaa viimeisen löydetyn tuotenimen yksikköhinnan, oikeaoppisesti olis pitänyt poistella turhat koodista, mutta ei väliä(tällä kertaa yksikköhinta sama)
      With HakuAlue
      Set Solu = .Find(What:=Hakuehto)
      If Not Solu Is Nothing Then
      Ekaosoite = Solu.Address
      Do
      Set HaeArvot2 = Solu.Offset(0, 2)
      Set Solu = .FindNext(Solu)
      Loop While Not Solu Is Nothing And Solu.Address Ekaosoite
      End If
      End With

      End Function

      Keep EXCELing
      @Kunde


    • Mahtavaa settiä löytyy täältä! Itsellä samanlaiset taulukot ja tarve makroille. Kopioinkin tästä suoraan koodin ja lisäsin moduliin. Itsellä kuitenkin antaa virheilmoituksen "syntax error" kohtaan HaeArvot = HaeArvot Solu.Offset(0, 3).Value. Koko rivi on myös punainen samoin kuin rivi "Loop While Not Solu Is Nothing And Solu.Address Ekaosoite". Käytössä on 2016 Excel. Onko hajua miksi antaa virheilmoituksen?


    • Anonyymi kirjoitti:

      Mahtavaa settiä löytyy täältä! Itsellä samanlaiset taulukot ja tarve makroille. Kopioinkin tästä suoraan koodin ja lisäsin moduliin. Itsellä kuitenkin antaa virheilmoituksen "syntax error" kohtaan HaeArvot = HaeArvot Solu.Offset(0, 3).Value. Koko rivi on myös punainen samoin kuin rivi "Loop While Not Solu Is Nothing And Solu.Address Ekaosoite". Käytössä on 2016 Excel. Onko hajua miksi antaa virheilmoituksen?

      foorumi on hävittänyt koodista erisuuret merkit kummastakin koodista
      eli rivit pitäisi olla tällaisia
      Loop While Not Solu Is Nothing And Solu.Address (tähäni merkit) Ekaosoite
      tähän merkit kohtaan ilman sulkuja siis merkit < ja >

      Keep EXCEling
      @Kunde


    • kunde kirjoitti:

      foorumi on hävittänyt koodista erisuuret merkit kummastakin koodista
      eli rivit pitäisi olla tällaisia
      Loop While Not Solu Is Nothing And Solu.Address (tähäni merkit) Ekaosoite
      tähän merkit kohtaan ilman sulkuja siis merkit < ja >

      Keep EXCEling
      @Kunde

      Tuo kirjoittamasi rivi meni normaalin väriseksi mutta edelleen toi ensimmäinen rivi "HaeArvot = HaeArvot Solu.Offset(0, 3).Value" on punaisena ja antaa virheilmoituksen "syntax error".


    • Hei,
      makro näyttää toimivan hienosti muuten mutta oma Excelini ei sulata riviä "HaeArvot = HaeArvot Solu.Offset(0, 3).Value". Rivi on punaisena ja koodin ajo tyssää tuohon. Onko mitään aavistusta missä vika voisi olla?


    • Anonyymi kirjoitti:

      Hei,
      makro näyttää toimivan hienosti muuten mutta oma Excelini ei sulata riviä "HaeArvot = HaeArvot Solu.Offset(0, 3).Value". Rivi on punaisena ja koodin ajo tyssää tuohon. Onko mitään aavistusta missä vika voisi olla?

      foorumi hukannut ja- merkin &
      eli pitäisi olla
      "HaeArvot = HaeArvot (tähän ja- merkki )Solu.Offset(0, 3).Value

      tähän merkit kohtaan ilman sulkuja siis ja-merkki &

      Keep EXCEling
      @Kunde


    • kunde kirjoitti:

      foorumi hukannut ja- merkin &
      eli pitäisi olla
      "HaeArvot = HaeArvot (tähän ja- merkki )Solu.Offset(0, 3).Value

      tähän merkit kohtaan ilman sulkuja siis ja-merkki &

      Keep EXCEling
      @Kunde

      Kannattaa laittaa koodi Pastebiniin https://pastebin.com/ ja oikean kielen syntaksikorostus päälle. Sitten vaan linkki palstalle. Pääsee vähemmillä väärinkäsityksillä.


    • Anonyymi kirjoitti:

      Kannattaa laittaa koodi Pastebiniin https://pastebin.com/ ja oikean kielen syntaksikorostus päälle. Sitten vaan linkki palstalle. Pääsee vähemmillä väärinkäsityksillä.

      Koodit on postattu vuonna 2014 ja silloin ei ollut tommosia ongelmia . Foorumin ulkonäköä fiksailtu ja uusittu sen jälkeen ja koodista kadonnut sitten noita tiettyjä merkkejä...


    • kunde kirjoitti:

      Koodit on postattu vuonna 2014 ja silloin ei ollut tommosia ongelmia . Foorumin ulkonäköä fiksailtu ja uusittu sen jälkeen ja koodista kadonnut sitten noita tiettyjä merkkejä...

      Ylläpidossa ei päde sääntö "Älä korjaa, jos se ei ole rikki"


  • Esimerkki:
    Jos sinulla on Taul1:sessä tuo mainitsemasi tuoteluettelo
    A-sarake "Tuote"
    D-sarake "Tilausmäärä"

    Tee Taul2:
    A1 anna haettavan tuotteen nimi
    B1=SUMMA.JOS(Taul1!A:A;A1;Taul1!D:D)
    Eli kaava hakee kaikki A1:seen annetun tuotteen vastaavuudet Taul1 A-sarakkeelta ja laskee niitä vastaavat "Tilausmäärät" D-sarakkeelta yhteen
    Kaavassa A:A ja D:D tarkoittavat että hakee vastinetta kaikista A ja D sarakkeiden soluista. Jos haluat rajata hakualuetta niin vaikka A1:A1000 ja D1:D1000

  • Kiitos paljon

  • Tuo summa.jos toimii moitteetta. Miten jos haluan sen lisäksi tuoda Taul1:sen C sarakkeessa olevan yksikköhinnan. Se pitäisi sijoitta Taul2:n C sarakkeeseen. Eli pitäisi kohdistaa kukin haettu tuote (Taul2, A1 sarake ja siitä eteenpäin) Taul1:ssä olevaan yksikköhintaan, jotka ovat samat olipa rivejä kuinka paljon tahansa , kun vain se kohdistetaan oikeaan tuotteeseen.

  • Näin minä tekisin.
    Kopioi Taul1 A-sarakkeen kaikki "Tuotenimikkeen" sisältävät solut (Valitse solu A1. Paina Ctrl ja Vaihto pohjaan ja paina "nuoli alas" painiketta, kaikki A-sarakkeen dataa sisältävät solut tulevat valituiksi)
    Liitä kopioidut solut Taul2 A-sarakkeelle
    Kun solut ovat vielä liittämisen jälkeen valittuina niin avaa ylhäältä "Tiedot"-välilehti.
    Sieltä löytyy painike "Poista kaksoiskappaleet".
    Nyt sinulle jää vain yksi uniikki nimike kutakin.
    Taul2 B1=SUMMA.JOS(Taul1!A:A;A1;Taul1!D:D)
    Taul2 C1=SUMMA.JOS(Taul1!A:A;A1;Taul1!C:C)
    Valitse B1 ja C1 ja vedä kaava alaspäin niinpitkälle kuin tuotteita riittää
    Jos käytät rajattua hakualuetta niin laita "dollarimerkit" että hakualue pysyy samana kaikille alaspäin kopioiduille kaavoille ($A$1:$A$1000)

    • Sori tuli pieni lapsus. Eihän noita yksikköhintoja saa laskea yhteen vaan ne pitää hakea PHAKU-funktiolla. Eli
      Taul2 C1=PHAKU(A1:Taul1!A:D;3;0)
      Eli kaava hakee A1:sen tuotetta Taul1 A-sarakkeelta ja antaa sitä vastaavan hinnan Taul1 C-sarakkeelta.
      PHAKU-funktiossa annetaan ensin haettava (A1), sitten mistä haetaan (Taul1A:D sarakkeilta).
      3 tarkoittaa että haetaan alueen A-D 3 sarakkeelta eli C:ltä ja nolla tarkoittaa että haetaan täysin samaa vastaavuutta haettavalta


suomi24-logo

Osallistu keskusteluun

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

Luetuimmat keskustelut

  1. En ymmärrä holokaustin kieltäjiä?

    Aivan sama kuin kieltäisi ettei 2 maailmansotaa ole ollutkaan. Onko heillä pimeä alue tuolta osin vai onko se tahallista kieltämistä. Jos myöntäisi se
    Maailman menoa
    310
    2776