Private Sub CommandButton1_Click()
Call Hapus
Sheets("data").Range("A6:k110").Value = ""
a = Val(TextBox1.Text)
b = TextBox2.Value
c = a + 5
No = 0
For NOMOR = 1 To a
No = No + 1
Cells(No + 5, 1).Value = No
Next NOMOR
For i = 6 To c
Cells(i, 2) = b
Next i
[k6:k106].Formula = "=CONCATENATE(b6, a6)"
Application.DisplayFormulaBar = False
'copy filter dan buat sheet baru
Dim sheetCopy As Worksheet
Dim sheetPaste As Worksheet
Dim sheetBuat As Worksheet
Dim Rng As Range
Set sheetCopy = ThisWorkbook.Worksheets("Data")
Set Rng = sheetCopy.Range("c5")
Dim iRowAwal As Integer
Dim iRowAkhir As Integer
Dim iRowTujuan As Integer
Dim sheetFilter As String
Dim sheetSama As Boolean
iRowAkhir = sheetCopy.Cells(sheetCopy.Rows.Count, 1).End(xlUp).Row
For iRowAwal = Rng.Row To iRowAkhir
sheetSama = False
sheetFilter = sheetCopy.Cells(iRowAwal, 11).Text
For Each sheetBuat In ThisWorkbook.Worksheets
If sheetFilter = sheetBuat.Name Then
Set sheetPaste = sheetBuat
sheetSama = True
Exit For
End If
Next
If Not sheetSama Then
Set sheetPaste = ThisWorkbook.Worksheets.Add(before:=sheetCopy)
sheetPaste.Name = sheetFilter
End If
sheetCopy.Rows(5).Copy sheetPaste.Rows(5)
iRowTujuan = sheetPaste.Cells(sheetPaste.Rows.Count, 1).End(xlUp).Row
sheetCopy.Rows(iRowAwal).Copy sheetPaste.Rows(iRowTujuan + 1)
Next iRowAwal
sheetCopy.Select
Set Rng = Nothing
Set sheetCopy = Nothing
Sheets("data").Range("A6:k110").Value = ""
Unload Me
Sheets("data").Select
End Sub
Private Sub CommandButton2_Click()
Dim sheet As Worksheet
Application.DisplayAlerts = False
For Each sheet In ThisWorkbook.Worksheets
If LCase(sheet.Name) <> "data" Then sheet.Delete
Next
Application.DisplayAlerts = True
Sheets("data").Range("O1:O200").Value = ""
Unload Me
End Sub
Private Sub ListBox1_Click()
For k = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(k) Then
Sheets(ListBox1.List(k)).Select
Sheets(ListBox1.List(k)).Cells.SpecialCells(xlLastCell).Select
Range(Selection, Cells(1, 1)).Select
End If
Next
End Sub
Private Sub TextBox1_Change()
If TextBox1 = vbNullString Then Exit Sub
If Not IsNumeric(TextBox1) Then
MsgBox "Maaf, hanya data berupa angka yang diijinkan", 16, "Validasi"
TextBox1 = vbNullString
End If
End Sub
Private Sub UserForm_Initialize()
For k = 2 To Sheets.Count
ListBox1.AddItem Sheets(k).Name
Next
End Sub
sampel file silahkan unduh pada tautan berikut :
Membuat Banyak Sheet sekaligus
Call Hapus
Sheets("data").Range("A6:k110").Value = ""
a = Val(TextBox1.Text)
b = TextBox2.Value
c = a + 5
No = 0
For NOMOR = 1 To a
No = No + 1
Cells(No + 5, 1).Value = No
Next NOMOR
For i = 6 To c
Cells(i, 2) = b
Next i
[k6:k106].Formula = "=CONCATENATE(b6, a6)"
Application.DisplayFormulaBar = False
'copy filter dan buat sheet baru
Dim sheetCopy As Worksheet
Dim sheetPaste As Worksheet
Dim sheetBuat As Worksheet
Dim Rng As Range
Set sheetCopy = ThisWorkbook.Worksheets("Data")
Set Rng = sheetCopy.Range("c5")
Dim iRowAwal As Integer
Dim iRowAkhir As Integer
Dim iRowTujuan As Integer
Dim sheetFilter As String
Dim sheetSama As Boolean
iRowAkhir = sheetCopy.Cells(sheetCopy.Rows.Count, 1).End(xlUp).Row
For iRowAwal = Rng.Row To iRowAkhir
sheetSama = False
sheetFilter = sheetCopy.Cells(iRowAwal, 11).Text
For Each sheetBuat In ThisWorkbook.Worksheets
If sheetFilter = sheetBuat.Name Then
Set sheetPaste = sheetBuat
sheetSama = True
Exit For
End If
Next
If Not sheetSama Then
Set sheetPaste = ThisWorkbook.Worksheets.Add(before:=sheetCopy)
sheetPaste.Name = sheetFilter
End If
sheetCopy.Rows(5).Copy sheetPaste.Rows(5)
iRowTujuan = sheetPaste.Cells(sheetPaste.Rows.Count, 1).End(xlUp).Row
sheetCopy.Rows(iRowAwal).Copy sheetPaste.Rows(iRowTujuan + 1)
Next iRowAwal
sheetCopy.Select
Set Rng = Nothing
Set sheetCopy = Nothing
Sheets("data").Range("A6:k110").Value = ""
Unload Me
Sheets("data").Select
End Sub
Private Sub CommandButton2_Click()
Dim sheet As Worksheet
Application.DisplayAlerts = False
For Each sheet In ThisWorkbook.Worksheets
If LCase(sheet.Name) <> "data" Then sheet.Delete
Next
Application.DisplayAlerts = True
Sheets("data").Range("O1:O200").Value = ""
Unload Me
End Sub
Private Sub ListBox1_Click()
For k = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(k) Then
Sheets(ListBox1.List(k)).Select
Sheets(ListBox1.List(k)).Cells.SpecialCells(xlLastCell).Select
Range(Selection, Cells(1, 1)).Select
End If
Next
End Sub
Private Sub TextBox1_Change()
If TextBox1 = vbNullString Then Exit Sub
If Not IsNumeric(TextBox1) Then
MsgBox "Maaf, hanya data berupa angka yang diijinkan", 16, "Validasi"
TextBox1 = vbNullString
End If
End Sub
Private Sub UserForm_Initialize()
For k = 2 To Sheets.Count
ListBox1.AddItem Sheets(k).Name
Next
End Sub
sampel file silahkan unduh pada tautan berikut :
Membuat Banyak Sheet sekaligus
No comments:
Post a Comment