Function pilihcopy() As Integer
pilihcopy = 0
If lstSheets.ListCount > 0 Then
For k = 0 To lstSheets.ListCount - 1
If lstSheets.Selected(k) Then
pilihcopy = pilihcopy + 1
End If
Next
End If
End Function
Private Sub CommandButton1_Click()
Dim Satukandata As Worksheet
Dim dataCopyl As Range
Dim Sheets_baru As String
Sheets_baru = Me.Nama_sheet_baru
If Sheets_baru = ""
Then
MsgBox "Ketik nama sheet
baru"
Me.Nama_sheet_baru.SetFocus
Exit Sub
End If
On Error Resume Next
Set Satukandata = Sheets.Add(after:=Sheets(5))
Satukandata.Name = Sheets_baru
If Err = 1004 Then
MsgBox Err.Description
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
Exit Sub
End If
On Error GoTo 0
Set dataCopyl = Satukandata.Cells(1, 1)
For k = 0 To lstSheets.ListCount - 1
If lstSheets.Selected(k) Then
Sheets(lstSheets.List(k)).Select
Sheets(lstSheets.List(k)).Cells.SpecialCells(xlLastCell).Select
Range(Selection, Cells(1,
1)).Select
Selection.Copy
Satukandata.Select
dataCopyl.Select
Satukandata.Paste
Selection.PasteSpecial Paste:=xlPasteValues
Selection.SpecialCells(xlLastCell).Select
Set dataCopyl =
Satukandata.Cells(ActiveCell.Row + 1, 1)
End If
Next
Unload Me
End Sub
Private Sub CommandButton2_Click()
Dim Cnt As Long, i As Long
Cnt = Sheets.Count
Application.DisplayAlerts = False
For i = Cnt - 0 To 6 Step -1
Sheets(i).Delete
Next i
Application.DisplayAlerts = True
End Sub
Private Sub UserForm_Initialize()
For k = 1 To Sheets.Count
lstSheets.AddItem Sheets(k).Name
Next
End Sub
Baca juga :
- Input Pilihan Ke Tabel Kolom
- Input Pilihan Ke Tabel Baris
- Input Menolak Data Ganda
- Input Transpose
- Kosa Kata Dasar dalam VBA
- Rumus Menjadi Kode VBA
DAPATKAN PAKET BELAJAR EBOOK VBA
- Paket Belajar Ebook pdf full VBA
- Input Pilihan Ke Tabel Baris
- Input Menolak Data Ganda
- Input Transpose
- Kosa Kata Dasar dalam VBA
- Rumus Menjadi Kode VBA
DAPATKAN PAKET BELAJAR EBOOK VBA
- Paket Belajar Ebook pdf full VBA
No comments:
Post a Comment