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

• #32228 Fferi50 Topikgazda b3n1t0 #32226

  Új Válasz 2016-08-02 12:58:03 #32228

  Ú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 b3n1t0 #32226 üzenetére

  Szia!

  A következő makró egy új munkalapra kibontja a sorokat, úgy hogy minden új sor után tesz egy üres sort, illetve a legelső sorba beírja az eredeti értékeket - ezt a sort el tudod hagyni, ha kitörlöd, nem okoz semmi problémát, megjegyzésben mellé írtam.

  Sub kibonto()
Dim rngalap As Range, rngdatum As Range, wsh1 As Worksheet, wsh2 As Worksheet, xx As Integer, sor As Range, cl As Range
Set wsh1 = ActiveSheet
Set rngalap = Intersect(wsh1.UsedRange, wsh1.UsedRange.Parent.Columns("K:AH"))
Set wsh2 = Worksheets.Add(after:=Sheets(ActiveSheet.Name))
xx = 1
For Each sor In rngalap.Rows
sor.Copy Destination:=wsh2.Cells(xx, "K") ' ez az eredeti értéket tartalmazza, ha nincs rá szükséged akkor kitörölheted a következő sorral együtt
xx = xx + 1
Set rngdatum = wsh1.Range("AJ" & sor.Row & ":AQ" & sor.Row)
For Each cl In rngdatum.Cells
If IsEmpty(cl) Then Exit For
wsh2.Cells(xx, "K").Value = sor.Cells(1) + cl.Value
Range(wsh2.Cells(xx, "L"), wsh2.Cells(xx, "O")).Value = Range(sor.Cells(2), sor.Cells(5)).Value
Range(wsh2.Cells(xx, "P"), wsh2.Cells(xx, "AH")).Formula = "=int(" & sor.Cells(6).Address(external:=True, columnabsolute:=False) & "*" & cl.Offset(0, 8).Address(external:=True, rowabsolute:=True, columnabsolute:=True) & "/ 100)"
Range(wsh2.Cells(xx, "P"), wsh2.Cells(xx, "AH")).Value = Range(wsh2.Cells(xx, "P"), wsh2.Cells(xx, "AH")).Value
xx = xx + 1
Next
xx = xx + 1
Next
End Sub

  Üdv.

• #32227 bsasa1 csendes tag b3n1t0 #32226

  Új Válasz 2016-08-02 11:36:29 #32227

  Ú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

  

  bsasa1

  csendes tag

  válasz b3n1t0 #32226 üzenetére

  Szia!

  Hát nem vagyok valami nagy vba-s, de egy régebbi makrómat átszabtam a tábládra.
  Sor azonosítók nem látszódnak, feltételeztem, hogy a 2. sorban van adat.
  Nálam működik, de egy hozzáértő biztos szebben oldaná meg.

  Sub makro1()

Dim i As Integer, j As Integer, f As Integer
Dim sor As Integer, hova As Integer

hova = InputBox(prompt:="Hányadik sorba?") - 1
sor = Range(("K2"), Range("K2").End(xlDown)).Rows.Count

For i = 1 To sor
For j = 1 To 8
Range("K" & hova + (i - 1) * 8 + j) = Range("K" & 1 + i) + Cells(2 + i - 1, 36 + j - 1)
Range("L" & 1 + i & ":O" & 1 + i).Copy Destination:=Range("L" & hova + (i - 1) * 8 + j & ":O" & hova + (i - 1) * 8 + j)
For f = 1 To 19
Cells(hova + (i - 1) * 8 + j, 16 + f - 1) = Cells(1 + i, 16 + f - 1) * Cells(2 + i - 1, 44 + j - 1)
Next f
Next j
Next i

End Sub

  a nullás sorok törlése kimaradt véletlen, de előbb ebéd

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