Catetan

MEMBUAT INPUT FORM SHEET INSERT GAMBAR DI EXCEL 7

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.

7 comments:

Pakde Karyo

6 Agt 2011 08.43.00
Blog ini benar-benar bagus dan mencerahkan. Bikin aku betah belajar disini. Thanks bos postingannya dan link saya dipasang disini. Insya Allah Link blog ini akan saya pasang di : http://pakdekaryo.blogspot.com juga.
Master Software Mobile

12 Mar 2012 16.41.00
Datang untuk silaturahmi gan...
MI MANBAIL FUTUH

11 Apr 2012 21.34.00
bagus banget nih blog. ane saluuuuuuut ma yg punya
MI MANBAIL FUTUH

11 Apr 2012 21.37.00
pak tolong bantu kami !!!!
buat data base nomer induk siswa yang hampir sama dengan program diatas, tapi mengenai data diri siswa mulai no, no induk, nisn,nama, ttl, asal sekolah, mulai masuk, nama ayah, nama ibu dll.
mohon hub email kami mimaf2008@yahoo.com
Ambo Ala

28 Mar 2015 16.42.00
Pak saya punya kendala dengan insert gambar...
saya ada file excel .xlm yang selalu error (error saat di buka kembali) saat saya masukkan gambar ke dalamnya
bagaimana solusinya? terimakasih
hippam soko tirto

30 Apr 2015 16.05.00
like
Toko Online Obat

16 Okt 2015 10.38.00
terimakasih banyak, menambah wawasan nih..

Posting Komentar