Keresés

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

  • Fire/SOUL/CD

    félisten

    válasz Fire/SOUL/CD #49628 üzenetére

    2 dolgot kell beállítanod a makróban, hogy HONNAN (eredeti adatok) és hogy HOVA (átalakított adatok) másolódjanak az adatok.
    Mindkét állítandó érték elé az [EZT KELL BEÁLLÍTANOD]kommentet tettem.

    Module1-be másolandó kód

    Option Explicit

    'Fire/SOUL/CD - 2022

    Public Sub Fire_Salex1_Process()

        'kötött formátum elválasztó karaktere
        Const MYDELIMITER = "-"

        'a feldogozandó adatok ebben az OSZLOP-ban és azon belül ebben a SOR-ban kezdődnek
        Dim MySrcColumn, MySrcColumnFirstCell As String
        'tartomány, amit a makró a MySrcColumn és MySrcColumnFirstCell értéke alapján határoz meg/generál
        Dim MySrcRange As Range
        'a feldolgozott adatokat ebbe a tartmányba írja a makró
        Dim MyDestRange As Range
        'a MySrcRange tartományban található aktuális cella tartománya (1 cella)
        Dim MyCell As Range
        
        'Variant típusú dinamikus tömb, ami az N számosságú halmaz N0 - N-1 elemét tárolja
        Dim MyUniqueSubStrArray() As Variant
        'Variant típusú dinamikus tömb, ami az N számosságú halmaz N0 - N-1 elemének feldolgozottságát tárolja (True/False)
        Dim MyUniqueSubStrProcessedArray() As Variant
        'szöveg típusú dinamikus tömb, amelynek elemei az aktuális cella
        'SPLIT parancs segítségével, MYDELIMITER paraméterrel elválasztott elemeit tartalmazza
        Dim MyTempArray() As String
        'átmeneti változó
        Dim MyTempStr As String
        'átmeneti változó, ami meghatározza, hogy a MyTempStr változó szerepel-e a MyUniqueSubStrArray-ben
        Dim MySubStr As Variant
        'nem megfelelő cella adat esetén megjelenő ablak visszatérési értéke
        Dim SelectedOptionOnWarningBox As Integer
        'makró-ciklusokban használt Long típusú változók (ciklus-számlálók)
        Dim i, j As Long
        
        'hogy gyorsabb legyen a makró, pár eseménykezelőt letiltunk
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        
        '[EZT KELL BEÁLLÍTANOD] - forrástartomány kezdetének beállítása (itt a példában A1) innen kezdődnek a feldolgozandó adatok
        MySrcColumn = "A"
        MySrcColumnFirstCell = "1"
        Set MySrcRange = Range(MySrcColumn & MySrcColumnFirstCell & ":" & MySrcColumn & Cells(Cells.Rows.Count, MySrcColumn).End(xlUp).Row)
        
        '[EZT KELL BEÁLLÍTANOD] - ettől a tartománytól kezdve írodnak ki a feldolgozott adatok (itt a példában B1-től)
        Set MyDestRange = Range("B1")
        
        'dinamikus tömbök méretének beállítása, egyéb változók inicializálása
        ReDim MyUniqueSubStrArray(Cells(Cells.Rows.Count, MySrcColumn).End(xlUp).Row)
        ReDim MyUniqueSubStrProcessedArray(Cells(Cells.Rows.Count, MySrcColumn).End(xlUp).Row)
        MyTempStr = ""
        i = 0
        j = 0
        
        'végignézzük a forrástartomány celláit egyenként
        For Each MyCell In MySrcRange
            'ha az aktuális cella üres, akkor kihagyjuk, egyébként feldolgozzuk
            If Not IsEmpty(MyCell.Value) Then
                'aktuális cellát feldaraboljuk az elválasztó-karakter szerint, kvázi, mint szövegből oszlopok
                MyTempArray = Split(MyCell.Value, MYDELIMITER)
                'kötött formátum szerint a MyTempArray elemeinek a száma 5-nek kell, hogy legyen
                'ezért megvizsgáljuk, hogy annyi-e
                If WorksheetFunction.CountA(MyTempArray) = 5 Then
                    'igen, 5 eleme van a tömbnek
                    'a MyTempStr dinamikus tömbbe bemásoljuk a MyTempArray első 4 elemét
                    MyTempStr = MyTempArray(0) + MYDELIMITER + MyTempArray(1) + MYDELIMITER + MyTempArray(2) + MYDELIMITER + MyTempArray(3)
                    'megvizsgáljuk, hogy a MyUniqueSubStrArray tömb elemei (az összes) tartalmazzák-e a MyTempStr-t
                    MySubStr = Filter(MyUniqueSubStrArray, MyTempStr)
                    'ha igen, akkor az elemeire bontott értékeket a MyDestRange + j + index címre másoljuk
                    'és a MyUniqueSubStrProcessedArray aktuális indexű elemét TRUE-ra állítjuk
                    'hogy a továbbiakban ne kelljen feldolgozni
                    If UBound(MySubStr) < 0 Then
                        MyUniqueSubStrArray(i) = MyTempStr
                        MyUniqueSubStrProcessedArray(i) = False
                        If (InStr(1, UCase(MyCell.Value), UCase(MyUniqueSubStrArray(i)), vbTextCompare)) And (MyUniqueSubStrProcessedArray(i) = False) Then
                            Cells(MyDestRange.Row + j, MyDestRange.Column) = MyTempArray(0) + MYDELIMITER + MyTempArray(1)
                            Cells(MyDestRange.Row + j + 1, MyDestRange.Column) = MyTempArray(0) + MYDELIMITER + MyTempArray(1) + MYDELIMITER + MyTempArray(2)
                            Cells(MyDestRange.Row + j + 2, MyDestRange.Column) = MyTempArray(0) + MYDELIMITER + MyTempArray(1) + MYDELIMITER + MyTempArray(2) + MYDELIMITER + MyTempArray(3)
                            Cells(MyDestRange.Row + j + 3, MyDestRange.Column) = MyCell.Value
                            j = j + 4
                            MyUniqueSubStrProcessedArray(i) = True
                        End If
                        i = i + 1
                    Else:
                        'ha nem, akkor az adott cella értékét be kell másolni a MyDestRange + j címre
                        Cells(MyDestRange.Row + j, MyDestRange.Column) = MyCell.Value
                        j = j + 1
                    End If
                
                Else:
                    'ha nem megfelelő a kötött formátum, akkor feltesszük a kérdést, hogy mi legyen
                    'kihagyja a makró a feldolgozásból, avagy kilépjen
                    SelectedOptionOnWarningBox = MsgBox("Nem szabványos formátumú adat a(z) " & MyCell.Address & " cellában:" & vbLf & _
                            MyCell.Value & vbLf & vbLf & _
                            "[OK] - hibás cella kihagyása" & vbLf & _
                            "[Mégse] - makró megállítása", vbQuestion + vbOKCancel)
                    If SelectedOptionOnWarningBox = vbCancel Then
                        Exit Sub
                    End If
                    
                End If
            
            End If
            
        Next MyCell
        
        'eseménykezelőket újra engedélyezzük
        Application.ScreenUpdating = True
        Application.EnableEvents = True
        
    End Sub

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