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

• #42893 Fire/SOUL/CD félisten Sesy #42875

  Új Válasz 2020-01-28 11:19:30 #42893

  Ú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

  

  Fire/SOUL/CD

  félisten

  válasz Sesy #42875 üzenetére

  Akkor még egy megoldás, csak a változatosság kedvéért...

  Alaphelyzet
  Makró futtatása után (Start Macro gomb)
  1. új munkalap | 2. új munkalap | 3. új munkalap
  Létrehozott munkalapok törlése után (Delete Created Sheets gomb)

  Macro forráskód

  Option Explicit

'Globális deklarációk
Dim MySrcRange, MyTempRange, MyCell As Range
Dim MySheetNamesArray() As String
Dim MySheetNamesIndexArray() As Long
Dim MyArrayIndex, MyDestOffset As Long
Dim MySrcSheetName, MySrcCodesColumn, MySrcCodesRow, MyDestCodesColumn, MyDestCodesRow As String

Private Sub CommandButton1_Click()

'Képernyő frissítés KI
Application.ScreenUpdating = False

'Forrás munkalap és cella beállítása
MySrcSheetName = "Munka2"
MySrcCodesColumn = "A"
MySrcCodesRow = "2"

'Cél cella beállítása
MyDestCodesColumn = "B"
MyDestCodesRow = "2"

'Forrás munkalap kiválasztása
ThisWorkbook.Worksheets(MySrcSheetName).Select

'Tartomány létrehozása a forrás adatok alapján
Set MySrcRange = Range(MySrcCodesColumn & MySrcCodesRow & ":" & MySrcCodesColumn & Cells(Cells.Rows.Count, MySrcCodesColumn).End(xlUp).Row)

'Dinamikus tömbők átméretezése a tartományban található cellák száma alapján (üreseket is beleértve)
ReDim MySheetNamesArray(0 To MySrcRange.Count - 1)
ReDim MySheetNamesIndexArray(0 To MySrcRange.Count - 1)

MyArrayIndex = 0
'Végignézzük a forrástartomány használt celláit
For Each MyCell In MySrcRange
'Ha üres, akkor kihagyjuk
If Not IsEmpty(MyCell) Then
'Aktuális munkalap létezik?
If Not SheetExists(MyCell.Text) Then
'Nem létezik, létrehozzuk és beírjuk a forráscella értékét
ActiveWorkbook.Sheets.Add After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count)
ActiveSheet.Name = MyCell.Text
Sheets(ActiveSheet.Name).Range(Cell1:=MyDestCodesColumn & MyDestCodesRow) = MyCell.Text
'Létrehozott munkalap nevét beírjuk a tömb megfelelő pozíciójába és megnöveljük a tömb indexét
MySheetNamesArray(MyArrayIndex) = MyCell.Text
MySheetNamesIndexArray(MyArrayIndex) = MySheetNamesIndexArray(MyArrayIndex) + 1
MyArrayIndex = MyArrayIndex + 1
Else
'Létezik, meghatározzuk a célcella eltolási értékét és beírjuk a forráscella értékét
MyDestOffset = GetDestRangeOffsetAsSheetName(MyCell.Text)
Sheets(MyCell.Text).Range(Cell1:=MyDestCodesColumn & (MyDestCodesRow + MySheetNamesIndexArray(MyDestOffset))) = MyCell.Text
'Eltolási értéket megnöveljöük az eltolási értékeket tartalmazó tömbben
MySheetNamesIndexArray(MyDestOffset) = MySheetNamesIndexArray(MyDestOffset) + 1
End If
End If
Next MyCell

'Forrás munkalap kiválasztása
ThisWorkbook.Worksheets(MySrcSheetName).Select

'Képernyő frissítés BE
Application.ScreenUpdating = True

'Start Macro gomb tiltása, Delete Created Sheets parancsgomb engedélyezése
CommandButton1.Enabled = False
CommandButton2.Enabled = True

End Sub

'Az adott munkalap létezik vagy nem
Public Function SheetExists(SheetName As String) As Boolean

Dim MyWorkSheet As Worksheet
Dim Result As Boolean

Result = False
For Each MyWorkSheet In ThisWorkbook.Sheets
If UCase(MyWorkSheet.Name) = UCase(SheetName) Then
Result = True
Exit For
End If
Next MyWorkSheet
SheetExists = Result

End Function

'A léterhozott munkalapon a cél cellák eltolási értékei
Public Function GetDestRangeOffsetAsSheetName(CurrentSheetName As String) As Long

Dim i As Long

For i = 0 To MySrcRange.Count - 1
If MySheetNamesArray(i) = CurrentSheetName Then
GetDestRangeOffsetAsSheetName = i
Exit For
End If
Next i

End Function

'A létrehozottt munkalapok törlése
Private Sub CommandButton2_Click()

Dim i As Long

'A megerősítő ablak(ok) megjelenésének tiltása
Application.DisplayAlerts = False

'Létrehozott munkalapok törlése
For i = 0 To MyArrayIndex - 1
If SheetExists(MySheetNamesArray(i)) Then Sheets(MySheetNamesArray(i)).Delete
Next i

'Forrás munkalap kiválasztása
ThisWorkbook.Worksheets(MySrcSheetName).Select

'A megerősítő ablak(ok) megjelenésének engedélyezése
Application.DisplayAlerts = True

'Start Macro gomb engedélyezése, Delete Created Sheets parancsgomb tiltása
CommandButton1.Enabled = True
CommandButton2.Enabled = False

End Sub

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