MEMBUAT INPUT FORM SHEET INSERT GAMBAR DI EXCEL 11

Sudah sekian lama tidak melakukan aktivitas blogging, kali ini aku coba bikin posting, mengenai Entry worksheet form dengan gambar.

Postingan ini sebenernya merupakan lanjutan dari postingan entry sheet form, tetapi diberi tambahan dengan menambahkan gambar yang bisa diambil di folder, dan dijadikan dalam satu row dengan database.

Untuk kodenya sendiri aku bagi menjadi 3 bagian

• Dengan menggunakan data validation untuk input cell
  
  
  1. Email
     
     
     =NOT(ISERROR(FIND("@",D12,1)))
  2. No Tlp/HP
     
     
     =ISNUMBER(D14)
  3. Tgl lahir
     
     Merupakan validation list
  
  
  4. Temp Gambar
     
     untuk temp gambar ada di cell I50, dimana aku kasih value yang sama dengan input cell nama, yang bertujuan supaya data value gambar tidak kosong.
  
  
• Kode makro
  
  untuk kode makro ada dua
  
  yang pertama kode untuk entry data
  
  
  Option Explicit
  
  Sub inputsheetform()
  
  Dim ws As Worksheet
  Dim ws1 As Worksheet
  Dim nRw As Long
  Dim i As Long
  Dim a As Long
  Dim rng As Range
  Dim rng2 As Range
  Dim rngCp As String
  Dim anum As String
  Dim rpic As String
  Dim sh as shape
  
  rngCp = "D7,D9,D12,D14,D17,E17,F17,I50" 'range input cell
  
  Set ws1 = Sheets("INPUT")
  Set ws = Sheets("DATABASE")
  
  'peringatan apabila cell input ada yang kosong
  With ws1
  Set rng = .Range(rngCp)
  If Application.CountA(rng) <> rng.Cells.Count Then
  MsgBox "Input Form diisi semua yach...!"
  Exit Sub
  End If
  End With
  Application.CutCopyMode = False
  With ws
  'mencari baris yang kosong
  nRw = .Cells(.Rows.Count, "B").End(xlUp).Offset(1, 0).Row
  anum = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
  rpic = .Cells(.Rows.Count, "I").End(xlUp).Offset(1, 0).Row
  End With
  
  ws1.Range("I50").Copy
  ws.Select
  Range("I" & rpic).Select
  ActiveSheet.Paste
  
  'melakukan input data
  With ws
  
  'input data sesuai range input cell
  i = 2
  For Each rng2 In rng.Cells
  ws.Cells(nRw, i).Value = rng2.Value
  i = i + 1
  Next rng2
  
  'membuat auto number
  If IsEmpty(.Range("A3")) Then
  .Range("A3") = 1
  Else
  .Range("A" & anum).Value = .Range("A" & anum).Offset(-1, 0) + 1
  End If
  End With
  'menghapus cell input, untuk diinput lagi
  With ws1
  On Error Resume Next
  With .Range(rngCp).Cells.SpecialCells(xlCellTypeConstants)
  .ClearContents
  Application.GoTo .Cells(1)
  End With
  For Each Sh In .Shapes
  If Not Application.Intersect(Sh.TopLeftCell, .Range("I50")) Is Nothing Then
  If Sh.Type = msoPicture Then Sh.Delete
  End If
  Next Sh
  On Error GoTo 0
  End With
  End Sub
  
  
  yang kedua kode makro untuk mengambil gambar dari folder yang diinginkan.
  
  Sub Gambar()
  Dim sGb As String, pic As Picture
  Dim ws1 As Worksheet
  
  Set ws1 = Sheets("INPUT")
  ws1.Range("I50").Select
  sGb = Application.GetOpenFilename _
  ("Gambar (*.gif; *.jpg; *.bmp; *.tif), *.gif; *.jpg; *.bmp; *.tif", _
  , "Pilih Gambar untuk diinsert")
  
  If sGb = "False" Then Exit Sub
  
  Set pic = ActiveSheet.Pictures.Insert(sGb)
  With pic
  
  .Height = ActiveCell.Height
  .Width = ActiveCell.Width
  .Top = ActiveCell.Top
  .Left = ActiveCell.Left
  .Placement = xlMoveAndSize
  End With
  ws1.Range("F17").Select
  
  Set pic = Nothing
  Set ws1 = Nothing
  
  End Sub
  

seperti biasa apabila ingin mempelajari lebih lanjut file bisa di download disini.