Excel - VBA - cella tartalom ősszefűzése

Ez a téma lezárásra került a moderátor által.
Címkék
Excel - VBA - cella tartalom ősszefűzése
2012-05-11T15:47:17+02:00
2012-09-25T11:20:59+02:00
2022-06-27T05:28:10+02:00
sofronia
Sziasztok!

Egy excel fülön a B6:B30 cellák tartalmát szeretném vesszővel elválasztva összefűzni. (fül név: Units)

A B6:B30 tartományban lehet, hogy csak B6-ban van szöveg, lehet, hogy mindegyikben. Ezt előre nem tudni.

Az összefűzött szövegnek egy másik fül (fül név: NC-register) egyik cellájában (D8) kéne megjelenni.

Az NC-register fülön van egy gomb, erre kattintva - sok egyéb más funkció mellett - ennek is meg kéne valósulni.

Köszi, ha tudtok segíteni
Mutasd a teljes hozzászólást!
Köszönöm, közben megszületett a megoldás:

Dim ce As Range, tmp As String
For Each ce In Sheets("Units").Range("B6:B30")
If ce.Value <> "" Then
tmp = tmp & ", " & ce.Value
End If
Next ce
If Len(tmp) > 1 Then Sheets("NC-register").Range("D8").Value = Mid(tmp, 3, Len(tmp))

Ennél maradok, ez működik nekem
Mutasd a teljes hozzászólást!
  • for each ciklussal végiglépkedsz a megfelelő_munkalap.range("B6:B30").cells gyűjteményen és egy változóba írod az értékeket vesszővel elválasztva sztring összefűzéssel (& operátor) és a végén kiiratod az értéket.
    Mutasd a teljes hozzászólást!
  • Alap esetben nem szükséges ciklus:
    Worksheets("NC-register").Range("d8").Value = _ Join(Application.WorksheetFunction.Transpose(Worksheets("Units").Range("b6:b30").Value), ",")

    Kérdés, hogy mit szeretnél az üres cellákkal kezdeni?
    Ha pl. a végén levő üres cellákat el akarod hagyni:
    s = Join(Application.WorksheetFunction.Transpose(Worksheets("Units").Range("b6:b30").Value), ",") While Right(s, 2) = ",," s = Left(s, Len(s) - 2) Wend If Right(s, 1) = "," Then s = Left(s, Len(s) - 1) Worksheets("NC-register").Range("d8").Value = s
    Mutasd a teljes hozzászólást!
  • De, pont, hogy alapesetben kell a ciklus.

    A transpose-join páros eléggé drága művelet.
    Mutasd a teljes hozzászólást!
  • A transpose-join páros eléggé drága művelet.


    Max. 25 darab cella esetén valszeg sem a memóriahasználat, sem a sebesség nem kritikus.

    Egyébként a 2. esetben sem kellene a ciklus, csak a Range("b31").End(xlUp).row-ig kell a tartományt kiválasztani, bár ezt ciklus esetén is meg lehet tenni.

    Mutasd a teljes hozzászólást!
  • Azért ha már felmerült, hogy mi a "drága", akkor az "ár" egyik eleme:

    x = Timer y1 = "" For Each c In Range("a1:A11000") y1 = y1 & "," & c.Value Next y1 = Mid(y1, 2) x2 = Timer y2 = Join(Application.Transpose(Range("a1:a11000").Value), ",") x3 = Timer Debug.Print x2 - x & " " & x3 - x2

    A sebesség:
    0,09375 0,0078125
    0,09375 9,765625E-03
    0,1015625 9,765625E-03
    0,1015625 9,765625E-03
    0,1015625 9,765625E-03
    Azért elég jelentős előny a join + transpose számára
    Mutasd a teljes hozzászólást!
  • Köszönöm, közben megszületett a megoldás:

    Dim ce As Range, tmp As String
    For Each ce In Sheets("Units").Range("B6:B30")
    If ce.Value <> "" Then
    tmp = tmp & ", " & ce.Value
    End If
    Next ce
    If Len(tmp) > 1 Then Sheets("NC-register").Range("D8").Value = Mid(tmp, 3, Len(tmp))

    Ennél maradok, ez működik nekem
    Mutasd a teljes hozzászólást!
  • Nálam meg pont fordítottak az arányok. Meg még 2 másik céges laptopon is...
    Mutasd a teljes hozzászólást!
  • Erre hányas szorzót kapsz?

    t1 = Timer s1 = "" For Each c In Range("a1:a60000") s1 = s1 & c.Value & "," Next t2 = Timer Debug.Print t2 - t1 s2 = "" While Timer - t2 < t2 - t1 s2 = s2 & Join(Application.WorksheetFunction.Transpose(Range("a1:a60000").Value), ",") Wend t3 = Timer Debug.Print t3 - t2 Debug.Print Len(s1), Len(s2) Debug.Print "szorzo ~~~:", 1# * Len(s2) / Len(s1)

    Mert én egy őskori, csiga lassú gépen 15-23 szorost, egy gyorsabb gépen 50-75 szorost.

    Amíg nem áll fenn a out of memory veszélye, addig a transpose nagyságrendekkel gyorsabb a for each-hez képest. Persze out of memory-nél bukott a mutatvány( ), de valamit valamiért...
    Mutasd a teljes hozzászólást!
  • A belső gépeinket kb. 8-17x-es különbség a ciklus javára. Ha a ciklust úgy futtatjuk (ez van a kódunkban), hogy előbb tömbbe írjuk az adatokat és a végén van csak egy join, akkor 21 - 37x-es különbség a ciklus javára. Kb. 1 hete futottunk bele ebbe a problémába, adiig nálunk is a transpose-os változat futott, de nagyon lassú volt, ezért írtuk át előbb sima ciklusra majd a tömb - join-os változatra. Azóta a sebesség elfogadható. Már készül az sql változat, addig csak kitart.
    Mutasd a teljes hozzászólást!
  • Különös belső gépetek lehet...

    De mindegy, a minta itt van, bárki megnézheti, hogy a gépén hogy viselkedik...
    Mutasd a teljes hozzászólást!
  • Sziasztok.
    Meg szeretném kérdezni, hogy van-e egyszerűbb makró a következőhöz. Szeretnék összefűzni 4 cellát 1 cellába...
    például:
    Cells(1, 8) = Cells(1, 9) & "-" & Cells(1, 10) & "-" & Cells(1, 11) & "-" & Cells(1, 12)
    Vagy Range("h1") = stb...
    De ez körülbelül nekem a h1-es cellától a h1200-as sorig kellene, hogy megtörténjen.
    Tehát...
    Cells(1, 8) = Cells(1, 9) & "-" & Cells(1, 10) & "-" & Cells(1, 11) & "-" & Cells(1, 12)
    Cells(2, 8) = Cells(2, 9) & "-" & Cells(2, 10) & "-" & Cells(2, 11) & "-" & Cells(2, 12)... stb.
    De nem igazán szeretnéha ilyen sok sorom lenne és leírni sem lenne egyszerű.
    Van erre valami egyszerűbb és összetettebb képlet, hogy ne kelljen 1200 sort leírnom?
    Tud valaki segíteni?
    Próbálkoztam, ilyennel próba képpen kevesebb sorral, mert nem tudtam pontosan, hogy reagál:

    For x = 1 to 12 (1200 helyett)
    For y = 1 to 12 (1200 helyett)
    For z = 1 to 12 (1200 helyett)
    Cells(x, 8) = Cells(y, 9)) & "-" & Cells(z, 10)...stb
    Next
    Next
    Next

    de csak a cellákban pörgette meg az összefűzéseket és végül minden sorban a 12.sorban lévő összefűzni való adatokat jelenítette meg.
    Valaki tud megoldást?
    Köszönöm.
    Mutasd a teljes hozzászólást!
  • Bár Árnyék szerint a ciklus a jobb, de a külső ciklus helyett én biztos, hogy a hivatkozást írnám át.

    cells(x,8)=
    helyett
    range("H1?H1200")=
    formát használnék.
    --
    Azt meg nem értem, hogy miért jó ennyiszer értéket adni a cells(x,8)-as cellának.
    Mutasd a teljes hozzászólást!
  • Ennek így nem sok értelme van, felesleges ennyi ciklust pörgetni, meg pont emiatt is rossz az eredmény:

    For x = 1 to 12 (1200 helyett)
    For y = 1 to 12 (1200 helyett)
    For z = 1 to 12 (1200 helyett)
    Cells(x, 8) = Cells(y, 9)) & "-" & Cells(z, 10)...stb
    Next
    Next
    Next


    Helyett ennyi:

    For x = 1 to 12 (1200 helyett)
    Cells(x, 8) = Cells(x, 9) & "-" & Cells(x, 10)...stb
    Next



    Mutasd a teljes hozzászólást!
  • For x = 1 to 12 (1200 helyett)
    Cells(x, 8) = Cells(x, 9) & "-" & Cells(x, 10)...stb
    Next

    helyett ennyi:

    Range("H1:H1200") = "=I1 & ""-"" & J1" Range("H1:H1200").Copy Range("H1:H1200").PasteSpecial xlPasteValues
    Mutasd a teljes hozzászólást!
  • Csináltam egy tömbös tesztet is:

    Sub p2() x = Timer y1 = "" t = Range("a1:A11000") For Each c In t y1 = y1 & "," & c Next y1 = Mid(y1, 2) x2 = Timer y2 = Join(Application.Transpose(Range("a1:a11000").Value), ",") x3 = Timer Debug.Print x2 - x & " " & x3 - x2 End Sub
    Az eredmények:

    Windows 7, Excel 2010:
    3,515625E-02 0,0234375
    0,03125 3,90625E-03
    0,03125 5,859375E-03
    0,0234375 5,859375E-03
    1,953125E-02 5,859375E-03
    2,734375E-02 5,859375E-03
    1,757813E-02 3,90625E-03
    2,929688E-02 3,90625E-03
    2,929688E-02 5,859375E-03


    Gyengébb gépen XP, 2003:
    0,1074219 6,445313E-02
    0,0625 0,015625
    0,0625 0,015625
    0,0625 0,015625
    0,078125 0,015625
    0,0625 0,015625
    0,078125 0,015625
    0,0625 1,757813E-02
    Mutasd a teljes hozzászólást!
  • Sziasztok. Köszönöm Robi80-nak és Micu-nak is a választ, mind kettő működik.
    Micunak a képleténél, annyit kellett hozzátennem, hogy a kijelölés
    megszűnjön,

    Application.CutCopyMode = False
    Range("h1").Select

    de ez semmit nem von le a megoldásból, mert ilyet nem közöltem az elején.
    Ha van ilyen én megosztanám a max. pontot kettőtök között.

    Köszi a segítséget...Üdv.
    Mutasd a teljes hozzászólást!
  • Szívesen
    Mutasd a teljes hozzászólást!
Ez a téma lezárásra került a moderátor által.
Címkék
abcd