Disable Copy Paste Excel File to Another Computer - Excel VBA

         

Kadang kita membuat file excel namun takut disalah gunakan oleh orang yang tidak bertanggung jawab dengan mengkopy isi sheet bahkan mengkopy file excel kita

         Ada beberapa tip untuk mengamankan file anda diantaranya adalah Mendisable file excel dicopy ke Computer lain

File bias dicopy ke computer lain namun file akan ditolak dan langsung terhapus bila seri no tidak sesuai dengan kode number serial yang dipasang di file tersebut sehingga file excel anda akan tetap aman

         Untuk mengetahui no Serial Hardis dari sebuah computer pastekan kode berikut pada sebuah modul

Sub Cek_noHardis ()

Sheets("Sheet1").Range("b1").Value = CreateObject("Scripting.FileSystemObject").GetDrive("C:\").SerialNumber

End Sub

Dan Kemudian Kode yang muncul akan kita pasang pada file excel kita  sesuai no seri hardis untuk computer yang bisa mengakses file tersebut

‘Pastekan kode pada Workbook sesuaikan no seri nya

Private Sub Workbook_Open()

Dim oFSO As Object

 Dim drive As Object

 Set oFSO = CreateObject("Scripting.FileSystemObject")

Set drive = oFSO.GetDrive("C:\")

If drive.SerialNumber <> 408299609 Then

Application.Run "Killy"

Set oFSO = Nothing

Set drive = Nothing

End If

End Sub

 ‘Pastekan pada modul

Sub Killy()

MsgBox "Illegal Copy ", vbExclamation + vbMsgBoxRight

Application.DisplayAlerts = False

ThisWorkbook.ChangeFileAccess xlReadOnly

Kill ThisWorkbook.FullName

ThisWorkbook.Close False

 Application.DisplayAlerts = False

End Sub

Untuk mendisabel copy paste dilembar excel pastekan juga kode berikut pada wookbook

Private Sub Workbook_Activate()

Application.CutCopyMode = False

Application.OnKey "^c", ""

Application.CellDragAndDrop = False

End Sub

Private Sub Workbook_Deactivate()

Application.CellDragAndDrop = True

Application.OnKey "^c"

Application.CutCopyMode = False

End Sub

Private Sub Workbook_WindowActivate(ByVal Wn As Window)

Application.CutCopyMode = False

Application.OnKey "^c", ""

Application.CellDragAndDrop = False

End Sub

Private Sub Workbook_WindowDeactivate(ByVal Wn As Window)

Application.CellDragAndDrop = True

Application.OnKey "^c"

Application.CutCopyMode = False

End Sub

Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)

Cancel = True

MsgBox "Right click menu deactivated." & vbCrLf & _

"Cannot copy or ''drag & drop''.", 16, "For this workbook:"

End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

Application.CutCopyMode = False

End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)

Application.OnKey "^c", ""

Application.CellDragAndDrop = False

Application.CutCopyMode = False

End Sub

Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)

Application.CutCopyMode = False

End Sub

Selamat Mencoba

Semoga bermanfaat

Impor Semua sheet pada dibanyak file - EXCEL VBA

Impor Semua sheet pada dibanyak file belajar excel VBA 

Sub merge_Files()
Dim xx, i As Integer
Dim yy As FileDialog
Dim w1, w2 As Workbook
Dim s1 As Worksheet
Set w1 = Application.ActiveWorkbook
Set yy = Application.FileDialog(msoFileDialogFilePicker)
yy.AllowMultiSelect = True
xx = yy.Show
For i = 1 To yy.SelectedItems.Count
Workbooks.Open yy.SelectedItems(i)
Set w2 = ActiveWorkbook
For Each s1 In w2.Worksheets
s1.Copy after:=w1.Sheets(w1.Worksheets.Count)
Next s1
w2.Close
Next i
End Sub


UNDUH SAMPEL FILE XLSM : DISINI


Silahkan dikembangkan dan semoga bermanfaat !!!

BELAJAR EXCEL VBA - REKAP SATU SHEET MULTY FILE

Sub kumpulkan()
FileTerpilih = Application.GetOpenFilename _
 ("XLSX File (*.xlsx),*.xlsx", Title:="Open file", MultiSelect:=True)
 If VarType(FileTerpilih) = vbBoolean Then
 Exit Sub
 End If
 NamaFileUtama = ActiveWorkbook.Name
 JumlahFile = UBound(FileTerpilih)
Application.DisplayAlerts = False
For i = 1 To JumlahFile
 Workbooks.Open FileTerpilih(i)
 With ActiveWorkbook.Worksheets("sheet1")
 BarisTerakhirFilePilihan = .Cells(.Rows.Count, 1).End(xlUp).Row
 BarisTerakhirFileUtama = Workbooks(NamaFileUtama).Worksheets("Sheet1") _
.Cells(Workbooks(NamaFileUtama).Worksheets("sheet1").Rows.Count, 1).End(xlUp).Row
   .Range("A6:M" & BarisTerakhirFilePilihan).Copy _
Destination:=Workbooks(NamaFileUtama).Worksheets("Sheet1").Range("A" & BarisTerakhirFileUtama + 1)
        End With
         ActiveWorkbook.Close
 Next i
 Application.DisplayAlerts = True
End Sub


Sub RESET()
Sheets("Sheet1").Range("a3:m1000").Clear
End Sub

CARA MUDAH COPY IMPOR DATA RANGE BEDA FILE EXCEL

PASTIKAN   Workbooks.Open("E:\EXTERNAL IMPOR\target.xlsx")

SIMPAN DI                                                                  DRIVE E
NAMA FOLDER :                                                       EXTERNAL IMPOR
NAMA FILE YANG AKAN DIIMPOT DATANYA : target.xlsx


PASTEKAN KODE BERIKUT PADA SEBUAH MODUL :

Sub impor_DATA1()
On Error Resume Next
Dim myData As Workbook
Dim myRekap As Workbook
Set myRekap = ActiveWorkbook
Set myData = Workbooks.Open("E:\EXTERNAL IMPOR\target.xlsx")

Worksheets("sheet1").Range("a4:H50").Select
Set salin = Worksheets("sheet1").Range("a4:H50")
Set simpan = myRekap.Sheets("sheet1").Range("a4:H50")
salin.Copy
simpan.PasteSpecial Paste:=xlPasteAll
myData.Save
myData.Close
End Sub

Sub impor_DATA222()
On Error Resume Next
Dim myData As Workbook
Dim myRekap As Workbook
Set myRekap = ActiveWorkbook
Set myData = Workbooks.Open("E:\EXTERNAL IMPOR\target.xlsx")

Worksheets("sheet2").Range("a4:H50").Select
Set salin = Worksheets("sheet2").Range("a4:H50")
Set simpan = myRekap.Sheets("sheet2").Range("a4:H50")
salin.Copy
simpan.PasteSpecial Paste:=xlPasteAll
myData.Save
myData.Close
End Sub

UNDUH FILE SAMPEL XLSM >>>>
DISINI

DEMIKIAN SEMOGA BERMANFAAT !!