- sziku69: Fűzzük össze a szavakat :)
- Sub-ZeRo: Euro Truck Simulator 2 & American Truck Simulator 1 (esetleg 2 majd, ha lesz) :)
- sziku69: Szólánc.
- Luck Dragon: Asszociációs játék. :)
- Magga: PLEX: multimédia az egész lakásban
- eBay-es kütyük kis pénzért
- ubyegon2: Airfryer XL XXL forrólevegős sütő gyakorlati tanácsok, ötletek, receptek
- laskr99: Processzor és videokártya szilícium mag fotók újrakezdés
- Hieronymus: A németországi vasúthálózat
- Viber: ingyen telefonálás a mobilodon
-
LOGOUT
A Microsoft Excel topic célja segítséget kérni és nyújtani Excellel kapcsolatos problémákra.
Kérdés felvetése előtt olvasd el, ha még nem tetted.
Új hozzászólás Aktív témák
-
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
- Kaspersky, McAfee, Norton, Avast és egyéb vírusírtó licencek a legolcsóbban, egyenesen a gyártóktól!
- Antivírus szoftverek, VPN
- Eladó Steam kulcsok kedvező áron!
- Windows 10 11 Pro Office 19 21 Pro Plus Retail kulcs 1 PC Mac AKCIÓ! Automatikus 0-24
- Számlás!Steam,EA,Epic és egyébb játékok Pc-re vagy XBox!
- Csere-Beszámítás! Felsőkategóriás számítógép PC Játékra! I9 13900KF / RTX 4080 / 32GB RAM / 1TB SSD
- Samsung Galaxy S23, 8/128 GB, Kártyafüggetlen
- ÁRGARANCIA!Épített KomPhone Ryzen 9 5900X 16/32/64GB RAM RTX 5070 12GB GAMER PC termékbeszámítással
- ROBUX ÁRON ALUL - VÁSÁROLJ ROBLOX ROBUXOT MÉG MA, ELKÉPESZTŐ KEDVEZMÉNNYEL (Bármilyen platformra)
- Telefon felvásárlás!! Honor 200 Lite, Honor 200, Honor 200 Pro, Honor 200 Smart
Állásajánlatok
Cég: Promenade Publishing House Kft.
Város: Budapest
Cég: PCMENTOR SZERVIZ KFT.
Város: Budapest