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

• #38346 Fferi50 Topikgazda botond187 #38340

  Új Válasz 2018-06-14 20:25:00 #38346

  Ú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

  

  Fferi50

  Topikgazda

  válasz botond187 #38340 üzenetére

  Szia!

  Ezt a makrót próbáld meg:

  Sub rendezo()
Dim sh As Worksheet, rng1 As Range, usor1 As Long, usor2 As Long, xx As Long, szine As Variant, ara As Variant, yy As Integer
usor1 = Range("B10000").End(xlUp).Row + 1
usor2 = Range("F10000").End(xlUp).Row
Range("E2:H" & usor2).Cut Destination:=Range("A" & usor1)
'Ez a r?sz az?rt van benne, hogy l?sd melyik sorokat szedte sz?t
usor1 = Range("B" & usor1 + usor2).End(xlUp).Row
Range("A2:A" & usor1).Formula = "=row() & "".sor"""
Range("A2:A" & usor1).Value = Range("A2:A" & usor1).Value
' itt a szeml?ltet? seg?d v?ge
Set rng1 = Range("A2:D2")
xx = 2
Do
With rng1
szine = Split(.Cells(3).Value, "/")
If UBound(szine) > 0 Then
ara = Split(.Cells(4), "/")
For yy = UBound(szine) To 0 Step -1
.Offset(1, 0).Insert shift:=xlShiftDown
.Copy rng1.Offset(1, 0)
.Offset(1, 0).Cells(3).Value = szine(yy)
If UBound(ara) >= UBound(szine) Then .Offset(1, 0).Cells(4).Value = ara(yy) Else .Offset(1, 0).Cells(4).Value = .Cells(4).Value
xx = xx + 1
Next
.Delete shift:=xlShiftUp
'xx = xx - 1
Else
xx = xx + 1
End If
End With
Set rng1 = Range("A" & xx & ":D" & xx)
Loop While rng1.Cells(2).Value <> ""
MsgBox "K?SZ"
End Sub

  Kiegészítés:
  1. Ha a D oszlopban dátumot látsz, ne ijedj meg, állítsd át az egész oszlop cellaformátumát számra 0 tizedessel.
  2. Ha színek vannak, de nincs hozzá külön ár, akkor minden színhez ugyanaz az ár kerül.

  Üdv.

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