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
UNDUH CONTOH FILE XLSM >>>>>>> Rekap multy Sheet
Demikian semoga bermanfaat!!!
No comments:
Post a Comment