-
Fototrend
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
-
Fferi50
őstag
Szia!
Az alábbi makrókat együtt kell bemásolnod egy modulba. Igyekeztem általánossá tenni.
Az alkotó elemeket az O oszloptól lehet beírnod. Az első oszlop 2. cellája az alapár.
A többi oszlop tartalmazza a megnevezést és az árakat párban. A makró a P2 cellából indul ki (de ez nem azt jelenti, hogy ide kell az alapárat írnod), ez legyen mindenképpen a kiindulási területen. A fejléceket nem másolja. Az utolsó oszlopba kerül az összár.
Most lehet 2-3-4 sőt akár 5 összetevője is az összárnak. Persze vedd figyelembe, hogy minél több a változat, annál több lesz a variáció és nő a futási idő is. Ha már unod, akkor a Ctrl+ Break megszakítja a futást, erre két helyen figyel a makró - ott ahol DoEvents van.
A varialhat makrót kell elindítanod, a másikat majd az meghívja, ha kell neki. Íme:Sub varialhat()
Dim u As Integer, alap As Double
Dim x As Long, y As Long, kepl As String
Dim arazas As Range, oszl As Range
Dim oszlopok As New Collection
Dim varia As Long
Dim oszlsz As Integer
Dim valami(), szoroz As Long
Set arazas = Range("P2").CurrentRegion
alap = arazas.Cells(2, 1).Value: kepl = "=A2"
varia = 1
For x = 2 To arazas.Columns.Count
With arazas.Columns(x)
oszlopok.Add Range(.Cells(2, 1), .Cells(2, 1).End(xlDown)), Str(x - 1)
If x Mod 2 = 0 Then varia = varia * oszlopok(x - 1).Cells.Count: kepl = kepl & "+" & Cells(2, x + 1).Address(rowabsolute:=False)
End With
DoEvents
Next
oszlsz = oszlopok.Count
Application.ScreenUpdating = False
If Range("A2") <> "" Then Range(Range("A2"), Cells(Range("A2").End(xlDown).Row, Range("A2").End(xlToRight).Column)).ClearContents
u = 2
Range(Cells(u, 1), Cells(u + varia - 1, 1)).Value = alap
y = 2
ReDim Preserve valami(1 To varia, 1 To oszlsz)
szoroz = 1
For x = oszlsz To 1 Step -1
sokszoroz oszlopok(x), x, szoroz, varia / oszlopok(x).Cells.Count / szoroz, valami
'oszl.Copy Destination:=Cells(u, y)
'Range(Cells(u, y), Cells(u + oszl.Cells.Count - 1, y)).AutoFill Destination:=Range(Cells(u, y), Cells(varia + 1, y)), Type:=xlFillCopy
If x Mod 2 = 1 Then szoroz = szoroz * oszlopok(x).Cells.Count
Next
y = 2 + oszlsz
Range(Range("B2"), Cells(UBound(valami, 1) + 1, y - 1)).Value = valami
Range(Cells(u, y), Cells(u + varia - 1, y)).Formula = kepl
Range(Cells(u, y), Cells(u + varia - 1, y)).Value = Range(Cells(u, y), Cells(u + varia - 1, y)).Value
Application.ScreenUpdating = True
Range("A1").Select
MsgBox "Készen vagyok!"
End Sub
Sub sokszoroz(ByRef mit, hova, hanyszor, ciklus, ByRef valami())
Dim x As Long, cl As Range, w As Integer, z As Long
x = 1
For z = 1 To ciklus
For Each cl In mit.Cells
For w = 1 To hanyszor
valami(x, hova) = cl.Value
x = x + 1
Next
Next
DoEvents
Next
End Sub
Ha bármi probléma adódik, csak írj.
Üdv.