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

• #54717 lappy őstag Fferi50 #54716

  Új Válasz 2025-11-06 08:35:44 #54717

  Ú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

  

  lappy

  őstag

  válasz Fferi50 #54716 üzenetére

  Public Sub OszlopbaTördelésOszloponként()
  Dim ws As Worksheet
  Dim lastRow As Long
  Dim chunkSize As Long
  Dim skipCount As Long
  Dim i As Long
  Dim targetStartRow As Long
  Dim pasteRow As Long
  Dim pasteCol As Long
  Dim dataRow As Long

  Set ws = ThisWorkbook.ActiveSheet

  ' Kérdés: hány elemet hagyjon ki
  skipCount = Application.InputBox("Hány elemet szeretnél kihagyni az elején?", "Elemek kihagyása", Type:=1)
  If skipCount < 0 Then Exit Sub

  ' Kérdés: hány elemet másoljon egy oszlopba
  chunkSize = Application.InputBox("Hány elemet szeretnél egy oszlopba másolni?", "Osztás megadása", Type:=1)
  If chunkSize <= 0 Then Exit Sub

  ' A oszlop utolsó adat sor
  lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

  ' Meghatározzuk, hova kezdje a másolást (ha már volt előző futás)
  If Application.WorksheetFunction.CountA(ws.Range("B:ZZ")) = 0 Then
  targetStartRow = 1
  Else
  targetStartRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row + 1
  End If

  ' Másolás
  dataRow = skipCount + 1
  pasteCol = 2 ' B oszlop
  pasteRow = targetStartRow

  Do While dataRow <= lastRow
  ' Egy oszlop feltöltése chunkSize elemmel
  For i = 1 To chunkSize
  If dataRow > lastRow Then Exit For
  ws.Cells(pasteRow, pasteCol).Value = ws.Cells(dataRow, 1).Value
  pasteRow = pasteRow + 1
  dataRow = dataRow + 1
  Next i

  ' Következő oszlop, vissza a kezdő sorra
  pasteCol = pasteCol + 1
  pasteRow = targetStartRow
  Loop

  MsgBox "? Kész! Az adatok oszloponként lettek átmásolva."

  End Sub
  itt a teljes kód és a
  Do While dataRow <= lastRow részt hagyja ki

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