Új hozzászólás Aktív témák

• #54737 Mutt senior tag Sesy #54734

  Új Válasz 2025-11-14 01:23:36 #54737

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Mutt

  senior tag

  válasz Sesy #54734 üzenetére

  Szia,

  Késő este ezt hoztam össze neked.
  Option Explicit
Sub Transzponalas()
    Dim adatsor As Range
    Dim adatok()
    
    'tegyük a kijelölt bemeneti adatokat egy tömbbe
    Set adatsor = Intersect(Selection, ActiveSheet.UsedRange)
    adatok = adatsor
    
    'kérdezzük meg hova kerüljön az eredmény
    Dim cel As Range
    Set cel = Application.InputBox(Prompt:="Add meg hova kerüljön az eredmény!", Title:="Információ", Type:=8).Range("A1")
    
    'nézzük meg nem írjuk-e felül a bemeneti tartományt
    If Not Intersect(adatsor, cel) Is Nothing Then
       Call MsgBox(Prompt:="A cél terület beleér a bemenő adatokat tartalmazó tartományba", Buttons:=vbOKOnly, Title:="Hiba")
       Exit Sub
    End If
    
    'ebbe a tömbbe fogjuk gyűjteni az eredményt
    Dim kimenet()
    ReDim kimenet(1 To 2)
    
    Dim x As Long
    Dim utolso_ertek As Double
    Dim temp1, temp2
    Dim v_sor As Long
    
    v_sor = 0
    
    With cel.Parent
        For x = 1 To UBound(adatok, 1)
            'a legelőször látott értékeket eltároljuk
            If x = 1 Then
                kimenet(1) = adatok(x, 1)
                utolso_ertek = adatok(x, 2)
                kimenet(2) = utolso_ertek
            Else
                'adjuk hozzá a további értékeket, ehhez terjesszük ki a tömbböt
                ReDim Preserve kimenet(1 To UBound(kimenet) + 2)
                kimenet(UBound(kimenet) - 1) = adatok(x, 1)
                kimenet(UBound(kimenet) - 0) = adatok(x, 2)
                                    
                'ha a korábban tároltnál nagyobb értéket látunk, akkor tegyük az alábbiakat
                '1) levágjuk a "kimenet" utolsó 2 elemét és eltároljuk őket
                '2) kiírjuk a "kimenet"-et
                '3) növeljük a sorszámot ahova az eredményeket tesszük
                '4) töröljük a "kimenet" tartalmát és beletesszük az 1-es lépésben tárolt értékeket
                
                If adatok(x, 2) > utolso_ertek Then
                    temp1 = kimenet(UBound(kimenet) - 1)
                    temp2 = kimenet(UBound(kimenet) - 0)
                    
                    ReDim Preserve kimenet(1 To UBound(kimenet) - 2)
                    cel.Offset(v_sor).Resize(, UBound(kimenet)) = kimenet
                    
                    v_sor = v_sor + 1
                    
                    ReDim kimenet(1 To 2)
                    kimenet(1) = temp1
                    kimenet(2) = temp2
                    utolso_ertek = temp2
                Else
                    utolso_ertek = adatok(x, 2)
                End If
            End If
        Next x
        
        'ha a ciklus végén maradt vmi a tömbben írjuk ki
        If kimenet(1) <> "" Then
            cel.Offset(v_sor).Resize(, UBound(kimenet)) = kimenet
        End If
    End With
    
End Sub

  Adtam hozzá megjegyzéseket.
  Amit én gondoltam végig, hogy a második oszlopban ha egy nagyobb számot látunk mint az előző sorban, akkor az előző sorig látott dolgokat ki kell írni és egy új sorba kell tenni majd az adatokat amíg megint találunk egy nagyobb számot mint az előző sorban.

  A kód egy tömbbe elkezdi gyűjteni az adatokat és ha jön a feltétel, akkor a tömb utolsó két elemét kivéve kiírjuk az addigi tartalmat. A tömböt nullázuk az aktuális sorban levő értékeket újra beletesszük és megyünk tovább. Közben mindig elmentjük egy változóba a második oszlop értékét.

  A kódban ami haladó VBA dolog:
  1) tömbök menetközbeni átméretezése (ReDim)
  2) tömbök tartalmának munkalapra kiírása (cel.Offset(v_sor).Resize(, UBound(kimenet)) = kimenet)

  Szerintem makró nélkül is megoldható a feladat. Power Query vagy az újabb Excel függvényekkel (LET és FÜGG.HALMOZÁS). Próbáljuk meg azt is?

  üdv

Új hozzászólás Aktív témák