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

• #49633 Fire/SOUL/CD félisten Fire/SOUL/CD #49628

  Új Válasz 2022-09-19 21:07:12 #49633

  Ú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

  

  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