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

• #49003 Mutt senior tag Salex1 #48995

  Új Válasz 2022-05-10 22:04:51 #49003

  Ú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 Salex1 #48995 üzenetére

  Szia,

  Itt az én változatom a felosztásra:

  Sub Atrendez()
Dim wsCel As Worksheet
Dim adatok, bont, aktualis()
Dim c As Long, i As Long
Dim oszlopok As Long, oszlopBont As Long
Dim sor As Long
Dim ertekek As String

'erre a munkalapra másoljuk az értékeket
Const cel = "Munka2"

'ezen nevú oszlopot kell sorokba bontani
Const bontani = "AH"
'a fenti oszlopnevet számmá alaktjuk
oszlopBont = Cells(1, bontani).Column

'beolvassuk a teljes adatsort
adatok = ActiveSheet.Range("A1").CurrentRegion
oszlopok = UBound(adatok, 2)

'cél munkalap beállítása
Set wsCel = Worksheets(cel)
'esetleg létező adatok törlése a cél munkalapról
wsCel.Cells.Clear

'erre szükség lehet a 11ezer sor kiírásakor
Application.ScreenUpdating = False

sor = 1
'végig megyünk a beolvasott adatokon
With wsCel
For c = 1 To UBound(adatok)
'egy átmeneti tömbbe (aktualis) beolvassuk az adatokat soronként
ReDim aktualis(1 To oszlopok)
For i = 1 To oszlopok
aktualis(i) = adatok(c, i)
Next i

'a bontani kívánt oszlopot feldolgozzuk, előtte levesszük a [ és ] jeleket
ertekek = Replace(Replace(aktualis(oszlopBont), "[", ""), "]", "")
bont = Split(ertekek, "','")

'ha üres volt a bontani kívánt érték akkor csak 1 sort kell írnunk
If UBound(bont) < 0 Then
.Cells(sor, 1).Resize(, oszlopok) = aktualis
sor = sor + 1
Else
'ha nem volt üres akkor visszont ismételni kell egymás után a dolgokat
For i = 0 To UBound(bont)
.Cells(sor, 1).Resize(, oszlopok) = aktualis
.Cells(sor, oszlopBont) = Replace(bont(i), "'", "")
sor = sor + 1
Next i
End If
Next c
End With
Application.ScreenUpdating = True

End Sub

  üdv

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