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
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
- Email
=NOT(ISERROR(FIND("@",D12,1))) - No Tlp/HP
=ISNUMBER(D14) - Tgl lahir
Merupakan validation list - 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.
- Email
- 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
