VBA-ban termékkódok alapján tartomány másolása

VBA-ban termékkódok alapján tartomány másolása
2020-09-17T13:37:28+02:00
2020-09-18T11:45:57+02:00
2022-10-15T21:16:36+02:00
Wilson kapitány
Sziasztok!

Van 2 db excel file, az egyikben az A oszlopban van 5 db termékkód, a másikban pedig szintén az A oszlopban van 50 db termékkód (az 5 db-ot is tartalmazza), ezen termékkódok mellett pedig 100 db áradat. Szeretném, ha a makró megtalálja a 5 db termékkódot, akkor a másik táblából a 100 árat mellé másolja. Most itt tartok, egyelőre, sajnos valami hibát már a LastRow2-nél jelez, nem fut végig. Illetve még FKERES-ben gondolkodtam, de ott meg csak tartományt hogyan tudnék bevinni?

Ha van bármilyen ötlet, köszi előre is.

Dim LastRow As Long LastRow = wsdest.Cells(wsdest.Rows.Count, "A").End(xlUp).Row Dim LastRow2 As Long LastRow2 = wcopy.Cells(wscopy.Rows.Count, "A").End(xlUp).Row For i = 2 To LastRow For k = 2 To LastRow2 If wsdest.Cells(i, 1) = wscopy.Cells(k, 1) Then wscopy.Range(Cells(i, 2), Cells(i, 101)).Copy wsdest.Cells(i, 2).PasteSpecial Paste:=xlPasteValues End If Next k Next i wsdest.Activate
Mutasd a teljes hozzászólást!
Szia

Sub próba()

    Dim LastRowDest As Long
    LastRowDest = Worksheets("termékek_árak").Cells(Worksheets("termékek_árak").Rows.Count, "A").End(xlUp).Row
    MsgBox LastRowDest
    Dim LastRowCopy As Long
    LastRowCopy = Worksheets("áradatok").Cells(Worksheets("áradatok").Rows.Count, "A").End(xlUp).Row
    MsgBox LastRowCopy
    Dim i, j As Byte
    
    Worksheets("áradatok").Select
    For i = 2 To LastRowDest
        For j = 2 To LastRowCopy
            If Worksheets("termékek_árak").Cells(i, 1) = Worksheets("áradatok").Cells(j, 1) Then
                Range(Cells(j, 2), Cells(j, 101)).Select
                Selection.Copy
                Worksheets("termékek_árak").Select
                Cells(i, 2).Select
                ActiveSheet.Paste
                Application.CutCopyMode = False
                Worksheets("áradatok").Select
            End If
        Next j
    Next i
    
    Worksheets("termékek_árak").Select

End Sub
Mutasd a teljes hozzászólást!

  • Szia!

    valami hibát már a LastRow2-nél jelez, nem fut végig

    Nem véletlen:

    LastRow2 = wcopy.Cells(wscopy.Rows.Count, "A").End(xlUp).Row

    wcopy-ban keresed, de az objektumod wscopy
    Miért nem használod az Option Explicit opciót a modul elején.
    Egyébként pedig ciklus helyett használd a Range Find metódusát.
    Üdv.
    Mutasd a teljes hozzászólást!
  • Szia, köszi szépen a választ!

    Attól tartok nem tudom ez az Option Explicit mire jó, illetve a Range Find sem, de a hibát kijavítom.

    Most ezzel próbálkoztam, az első oszlopt ezzel kitölti, már csak 99 van hátra :) Az altabla-t kihúzom a 100. adatik, de amikor azt írom, hogy 2 az eredm-nél, azt hogy lehetne megoldani, hogy 2-től a 101-ig menjen? KÖSZÖNÖM!

    LastRow = wsdest.Cells(wsdest.Rows.Count, "A").End(xlUp).Row LastRow2 = wscopy.Cells(wscopy.Rows.Count, "A").End(xlUp).Row Fotabla = wsdest.Range("A2:A" & LastRow) altabla = wscopy.Range("A2:B" & LastRow2) destSor = wsdest.Range("B2").Row destOszlop = wsdest.Range("B2").Column For Each cl In Fotabla eredm = Application.VLookup(cl, altabla, 2, False) If IsError(eredm) Then ' … nem talált Else wsdest.Cells(destSor, destOszlop) = eredm End If destSor = destSor + 1 Next cl
    Mutasd a teljes hozzászólást!
  • Mondjuk ez elég babrás, mert a destSor és destOszlop adatokat is folyton cserélnem kellene, nem tudom hogyan lehetne ezt szépen megoldani.

    Elején azt hittem, hogy erre elég a tudásom, végül ha a két A oszlopban egyezés van, azaz valamelyiket az 5 db kód közül az 50 termékkód között megtalálta, akkor a mellette lévő 100 árat másolja be. :(
    Mutasd a teljes hozzászólást!
  • Szia Wilson kapitány!
    Elöljáróban megtennéd, hogy a táblázatot is mellékeled a kód mellé?
    A kettő együtt csinál valamit.

    Ha az Option Explicit kifejezést használod, akkor az Excel szigorúan veszi a helyesírást. Figyelmeztet, ha valamit nem jó helyesírással - szintaktikával - kódolsz. Tehát segítségként használható.

    ...hogy lehetne megoldani, hogy 2-től a 101-ig menjen

    Lehet, hogy félreértettelek, ... de ismered az abszolút és a relatív cellahivatkozásokat?

    Végül mégegyszer: Tedd már meg , légy szíves, hogy a táblázatot is mellékeled! :)

    üdvözlettel
    verax
    Mutasd a teljes hozzászólást!
  • Szia!

    Attól tartok nem tudom ez az Option Explicit mire jó, illetve a Range Find sem

    Ezért kellene tanulmányoznod a VBA helpet  VBA Help
    Az Option Explicit kiszűri, ha előzetes deklaráció nélküli változót próbálsz használni - tehát a betű elütések már a futtatás előtt kiderülnek.
    A Find (mint a nevében is foglaltatik) érték keresésre használható.
    Üdv.
    Mutasd a teljes hozzászólást!
  • Sziasztok!

    Okés, srácok, mindjárt felrakok egy minta táblát, aztán abból talán érthető lesz, mit is szeretnék.

    Köszi szépen,
    Wilson kapitány
    Mutasd a teljes hozzászólást!
  • Sziasztok, küldöm a rövidített mintát, az első munkalapra kellene átvarázsolni a megfelelő sorokat a megfelelő termékek mellé.

    Köszönöm.
    Mutasd a teljes hozzászólást!
    Csatolt állomány
  • Szia

    Sub próba()

        Dim LastRowDest As Long
        LastRowDest = Worksheets("termékek_árak").Cells(Worksheets("termékek_árak").Rows.Count, "A").End(xlUp).Row
        MsgBox LastRowDest
        Dim LastRowCopy As Long
        LastRowCopy = Worksheets("áradatok").Cells(Worksheets("áradatok").Rows.Count, "A").End(xlUp).Row
        MsgBox LastRowCopy
        Dim i, j As Byte
        
        Worksheets("áradatok").Select
        For i = 2 To LastRowDest
            For j = 2 To LastRowCopy
                If Worksheets("termékek_árak").Cells(i, 1) = Worksheets("áradatok").Cells(j, 1) Then
                    Range(Cells(j, 2), Cells(j, 101)).Select
                    Selection.Copy
                    Worksheets("termékek_árak").Select
                    Cells(i, 2).Select
                    ActiveSheet.Paste
                    Application.CutCopyMode = False
                    Worksheets("áradatok").Select
                End If
            Next j
        Next i
        
        Worksheets("termékek_árak").Select

    End Sub
    Mutasd a teljes hozzászólást!
  • Köszönöm szépen, már nézem is és természetesen visszajelzek!
    Mutasd a teljes hozzászólást!
  • Ja! Bocs benne maradtak az üzenet ablakok :) Bocs! Töröld már ki azokat. légy szíves! :)

    ... amit ezenfelül ajánlanék:

    Ne vesződj felesleges változókkal, azok névadásával, ami viszont kell, annak következetes és beszédes nevet adj.
    üdvözlettel
    verax
    Mutasd a teljes hozzászólást!
  • Köszönöm szépen! Működik!

    Az MsgBox kikommentelése lehetséges valahogy, vagy zavart okoz? Ebben még kérhetem a segítségedet? Hogy ne jelenjen meg.

    Köszönöm szépen!
    Mutasd a teljes hozzászólást!
  • Szia!
    Bocsánatot kérek, hogy benne maradt!
    Egyszerűen csak töröld ki azt a sort. :)

    üdv
    verax
    Mutasd a teljes hozzászólást!
  • OK, köszönöm szépen :)
    Mutasd a teljes hozzászólást!
  • Szia!

    Az eredeti nagyobb excelembe átpakolva a kódot, vajon ennél a résznél miért adhat Owerflow hibát? Csak egy kicsit nagyobb a tábla, mint a másik, nem értem... 

    For j = 2 To LastRowCopy
    Mutasd a teljes hozzászólást!
  • Szia!
    Megmutatnád a LastRowCopy-hoz tartozó DIM sort?
    Üdv.
    Mutasd a teljes hozzászólást!
  • Szia!
    Az Owerflow  túlcsordulást jelent.

    A z i és j ciklus változók Byte típusúak. Ez a típus 0-255  tartományban vehet fel értéket. Az eredeti, nagyobb táblázatodban valószínűleg ennél nagyobb sorszámmal találkozik a program, amit már ebbe a típusú változóba nem tud bele illeszteni. Tehát célszerűbb lett volna eredetileg nagyobb egész típusú számként - Integer, Long - létrehoznom azokat.
    Tehát a javítandó sor Dim i, j as Byte ... és helyette Dim i, j as Long

    Bocs! ...de legalább ez is szóba jött :)

    üdv
    verax
    Mutasd a teljes hozzászólást!
  • Szia!

    A kód ezen részére gondolsz? Máris mutatom, de kicsiben működött:

    Dim LastRowDest As Long LastRowDest = Worksheets("termékek_árak").Cells(Worksheets("termékek_árak").Rows.Count, "A").End(xlUp).Row 'MsgBox LastRowDest Dim LastRowCopy As Long LastRowCopy = Worksheets("áradatok").Cells(Worksheets("áradatok").Rows.Count, "A").End(xlUp).Row 'MsgBox LastRowCopy Dim i, j As Byte
    Köszi szépen!
    Mutasd a teljes hozzászólást!
  • 460 :)

    Akkor ezért volt, ide okosodni jár az ember, jobb mint egy suli.

    Feri is, Te is szuperek vagytok. Hála!
    Mutasd a teljes hozzászólást!
  • Sziasztok!

    Arra vajon van lehetőség, hogy a tegnapi példában, amikor beviszi az adatokat a megfelelő sorokba, akkor maradnak üres cellák, hiányzó adatok. 

    Lehetséges-e, hogy egy For ciklus végigmegy a sorokon és ahol üreset talál, azt a sorban meglévő adatok átlagával helyettesíti. Olyan eseteim lesznek, hogy elvileg 100 adatot visz be minden egyes termékkód mellé, de némelyiknél pl. csak 75-től 100-ig lesznek adatok. Lehetne az is, hogy a 75-ös adattal feltölti 1-74-ig, vagy a 75-100 átlagával tölti fel 1-74-ig.

    Kétváltozós regressziónál pedig ki kellene tölteni valahogy minden cellát, erre lenne szükségem egy jó ötletre/segítségre.

    Köszönöm szépen.
    Mutasd a teljes hozzászólást!
  • Szia Wilson kapitány!

    :) Rossz a kérdés feltevés! :) helyesen...
    Abban hajlandóak vagytok-e segíteni ...
    ...mert, természetesen, megoldható az is hogy az üres mezőket valamilyen számítás - akár átlag - eredményével töltse fel.
    Mi legyen a helyettesítő érték számításának módja?
    Előfordulhat-e olyan eset, hogy például az első tíz cella tartalmaz értéket, a következő néhány cella üres, majd ismét olyan cellák következnek, amelyekben van adat ... azaz egybefüggő-e egy-egy sor adattartománya vagy lehet töredezett is?
    Az alapelv az lenne, hogy a már meglévő  két ciklust fejlesztenéd tovább.
    For i=1 to UtolsóCél
       For j=1 to UtolsóForrás
          If egyeznek-e a cellák Then
             For k=2 to 101
                If Cells(j,k)="" Then
                ide kerül a számítás ... az ötlethez az árképzés módját leíró további ismeretek szükségesek
                End If
             Next ...(k)
          End If
       Next ...(j)
    Next ...(i)

    üdv
    verax
    Mutasd a teljes hozzászólást!
  • Szia!

    Köszönöm, mindig igyekszem a maximális udvariassággal az itteni szakik segítségét kérni, ez a minimum, sajnálom, ha ez most nem sikerült, elnézést :)

    Köszi a tippet, már próbálom is! :)
    Mutasd a teljes hozzászólást!
Tetszett amit olvastál? Szeretnél a jövőben is értesülni a hasonló érdekességekről?
abcd