Ú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

• #42882 Delila_1 veterán Sesy #42875

  Új Válasz 2020-01-28 08:27:34 #42882

  Ú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

  

  Delila_1

  veterán

  válasz Sesy #42875 üzenetére

  Együttesen kijelölt lapokat lehet egyszerre formázni. Az első lapon állsz, majd a Shift gombot lenyomva tartva kijelölöd az utolsó formázni kívánt lapot.
  A formázás elvégzése után feltétlen szüntesd meg az együttes kijelölést!

• #42881 Delila_1 veterán Sesy #42875

  Új Válasz 2020-01-28 08:23:50 #42881

  Ú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

  

  Delila_1

  veterán

  válasz Sesy #42875 üzenetére

  Fferi gyorsabb volt, de azért én is beteszem a saját makrómat.

  Sub Szetvalogatas()
Dim sor As Long, lapnev As String, usor As Long, a

usor = Range("A" & Rows.Count).End(xlUp).Row

For sor = 2 To usor
lapnev = Right(Cells(sor, 1), Len(Cells(sor, 1)) - 3)
On Error Resume Next
Set a = Sheets(lapnev)
If Err.Number > 0 Then
Sheets.Add.Name = lapnev
Sheets(lapnev).Move After:=Sheets.Count
End If
Sheets(lapnev).Cells(sor, 2) = Sheets("Munka2").Cells(sor, 2)
Sheets("Munka2").Select
Next
Sheets("Munka2").Move After:=Sheets(1)
MsgBox "Kész a szétválogatás", vbInformation
End Sub

• #42876 Fferi50 Topikgazda Sesy #42875

  Új Válasz 2020-01-27 18:32:21 #42876

  Ú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 Sesy #42875 üzenetére

  Szia!
  Már megint kérdésem van:
  Ha számok vannak a munka2 lap A oszlopában, akkor honnan tudjuk, hogy mi a neve a keresendő munkalapnak? Mert csak számokat nem szerencsés munkalapnévnek adni.
  A formázáshoz:
  Egy munkalapot megformázol. Utána a formátum másolóval annyi munkalapra másolod, amennyire akarod. (Formátum másoló bekapcsolása kijelölöd a másolandó részt. Jobb egérgomb - a jobb oldalon levő ecsetre duplakatt. Addig marad bekapcsolva, amíg ESC-t nem nyomsz neki.)
  De a megformázott munkalapot sablonként is elmentheted és nyithatsz utána ugyanolyan munkalapokat.
  ÜDv.

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