-
IT café
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
-
Mutt
aktív 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
A tanácsaimat ingyen adom. Ha nem tetszik, akkor kérlek ne kritizáld! / https://github.com/viszi/codes/tree/master/Excel
Új hozzászólás Aktív témák
Állásajánlatok
Cég: Ozeki Kft.
Város: Debrecen