Hasil VBA Double bila digeser

  1. 2 tahun lalu

    Mohon bantuannya untuk mengatasi hasil VBA yang seperti screen shot di bawah ini dimana hasil dari vbs bisa di geser akan menimbulkan bayangan yang tidak bisa hilang. mohon solusinya.

    source code

    Option Explicit
    Dim CbLock As Boolean, Simpan As Boolean
    Dim FormMode As String
    Dim harga As Double
    Const MsgboxTitle = "Daftar Barang"

    '=================================================================================
    ' CCCCC
    '=================================================================================
    Private Sub CBTAMBAH_Click()
    Dim JmlMasuk, JmlKeluar, JmlSisa
    CbLock = True
    Unlok
    TBKODE.Value = Empty
    TBNAMA.Value = Empty
    TBSAT.Value = Empty
    harga = 0
    TBHARGA.Value = 0
    OPYES.Value = True
    OPNO.Value = False
    JmlMasuk = 0
    TBMASUK = JmlMasuk
    JmlKeluar = 0
    TBKELUAR = JmlKeluar
    JmlSisa = 0
    TBSISA = JmlSisa
    FormMode = "Tambah"
    End Sub

    Private Sub CBBATAL_Click()
    FormMode = "Ready"
    CbLock = False
    Unlok
    RefreshControl
    End Sub

    Private Sub CBEDIT_Click()
    CbLock = True
    Unlok
    FormMode = "Edit"
    End Sub

    Private Sub CBOK_Click()
    Dim LnBrg As Integer
    If TBKODE.Value = Empty Then
    MsgBox "kode barang masih kosong", vbInformation, MsgboxTitle
    Exit Sub
    End If
    If TBNAMA.Value = Empty Then
    MsgBox "nama barang masih kosong", vbInformation, MsgboxTitle
    Exit Sub
    End If
    If FormMode = "Tambah" Then
    LnBrg = SBBRG.Max + 1
    Else
    LnBrg = SBBRG.Value
    End If
    If Not CheckDup(TBKODE.Value, "A", LnBrg, FormMode) Then GoTo ErrOk
    With ThisWorkbook.Sheets("TbBarang")
    Application.ScreenUpdating = True
    .Unprotect
    .Range("A" & LnBrg).Value = TBKODE.Value
    .Range("B" & LnBrg).Value = TBNAMA.Value
    .Range("C" & LnBrg).Value = TBSAT.Value
    .Range("D" & LnBrg).Value = harga
    .Range("E" & LnBrg).Value = OPYES.Value
    MsgBox FormMode & " data berhasil", vbInformation, MsgboxTitle
    Simpan = True
    .Protect
    Application.ScreenUpdating = False
    End With
    If FormMode = "Tambah" Then
    Sekrol
    SBBRG.Value = SBBRG.Max
    End If
    CBBATAL_Click
    Exit Sub
    ErrOk:
    MsgBox "No ID sudah dipakai", vbCritical, MsgboxTitle
    Exit Sub
    End Sub

    Private Sub Label28_Click()

    End Sub

    Private Sub Label30_Click()

    End Sub

    Private Sub SBBRG_Change()
    RefreshControl
    End Sub

    Private Sub TBHARGA_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    On Error GoTo ErrHarga
    harga = TBHARGA.Value
    TBHARGA.Value = FormatNumber(harga, 0, vbTrue, vbTrue, vbTrue)
    Exit Sub
    ErrHarga:
    MsgBox "hANya boLeH bERISi aNGka!", vbOKOnly + vbCritical, MsgboxTitle
    harga = 0
    TBHARGA = FormatNumber(harga, 0, vbTrue, vbTrue, vbTrue)
    End Sub

    Private Sub TBHARGA_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    If IsNumeric(Chr(KeyAscii)) = False And KeyAscii <> vbKeyBack And KeyAscii <> 44 Then
    KeyAscii = 0
    End If
    End Sub

    Private Sub TBHARGA_Enter()
    TBHARGA.Value = harga
    End Sub

    Private Sub CBXKOLFILTER_Change()
    LBFILTER.RowSource = FilterBarang(TBFILTER.Value, CBXKOLFILTER.ListIndex)
    End Sub

    Private Sub LBFILTER_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Dim response As VbMsgBoxResult
    If LBFILTER.Value = Null Then Exit Sub
    response = MsgBox("tampilkan data " & LBFILTER.Value & " ??", vbYesNo + vbQuestion, MsgboxTitle)
    If response = vbNo Then Exit Sub
    SBBRG.Value = Application.WorksheetFunction.Match(LBFILTER.Value, ThisWorkbook.Sheets("TbBarang").Range("A:A"), 0)
    End Sub

    Private Sub TBFILTER_Change()
    LBFILTER.RowSource = FilterBarang(TBFILTER.Value, CBXKOLFILTER.ListIndex)
    End Sub

    Private Sub UserForm_Activate()
    Dim text1 As control
    Dim i As Integer
    Application.Calculation = xlCalculationManual
    ThisWorkbook.Activate
    Sheets("TbBarang").Select
    Application.ScreenUpdating = False
    Call Sekrol
    CBXKOLFILTER.Clear
    For i = 1 To 5
    CBXKOLFILTER.AddItem Sheets("TbBarang").Cells(1, i).Value
    Next i
    CBXKOLFILTER.ListIndex = 1
    CbLock = False
    Call Unlok
    FormMode = "Ready"
    Simpan = False
    Set text1 = Controls.Add("Forms.Label.1", "TT", True)
    text1.Move 12, 360, 420, 12
    text1.Caption = AuthorGen2()
    If SBBRG.Max = 1 Then
    MsgBox "Data masih kosong", vbInformation, MsgboxTitle
    Call CBTAMBAH_Click
    CBBATAL.Enabled = False
    Exit Sub
    End If
    RefreshControl
    End Sub

    Private Sub UserForm_Terminate()
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    ThisWorkbook.Sheets("TbBarang").Range("A" & SBBRG.Value & ":E" & SBBRG.Value).Select
    ThisWorkbook.Sheets("TbBarang").Protect
    If Simpan Then ThisWorkbook.Save
    End Sub

    '=================================================================================
    ' FFFFFFF
    '=================================================================================

    Private Function CheckDup(w As Variant, x As String, y As Integer, z As String) As Boolean
    Dim TempCD1, TempCD2, RgLook
    On Error GoTo ErrCheckDup
    CheckDup = True
    RgLook = x & "1:" & x & SBBRG.Max
    TempCD1 = Application.WorksheetFunction.CountIf(ThisWorkbook.Sheets("TbBarang").Range(RgLook), w)
    If z = "Tambah" Then
    If TempCD1 > 0 Then CheckDup = False
    ElseIf z = "Edit" Then
    If TempCD1 > 1 Then
    CheckDup = False
    ElseIf TempCD1 = 1 Then
    TempCD2 = Application.WorksheetFunction.Match(w, ThisWorkbook.Sheets("TbBarang").Range(RgLook), 0)
    If TempCD2 <> y Then CheckDup = False
    End If
    End If
    Exit Function
    ErrCheckDup:
    MsgBox "ErrCheckDup", vbCritical, MsgboxTitle
    CheckDup = False
    End Function

    '=================================================================================
    ' PPPPPPP
    '=================================================================================

    Private Sub Unlok()
    CBTAMBAH.Enabled = Not CbLock
    CBEDIT.Enabled = Not CbLock
    SBBRG.Enabled = Not CbLock
    CBOK.Enabled = CbLock
    CBBATAL.Enabled = CbLock
    TBKODE.Locked = Not CbLock
    TBNAMA.Locked = Not CbLock
    TBSAT.Locked = Not CbLock
    TBHARGA.Locked = Not CbLock
    OPYES.Locked = Not CbLock
    OPNO.Locked = Not CbLock
    End Sub

    Private Sub Sekrol()
    SBBRG.Max = LastCell(ThisWorkbook.Name , "TbBarang", "A")
    If SBBRG.Max <= 1 Then
    SBBRG.Min = 1
    Else
    SBBRG.Min = 2
    End If
    SBBRG.LargeChange = Round(SBBRG.Max / 5, 0)
    End Sub

    Private Sub RefreshControl()
    Dim JmlMasuk, JmlKeluar, JmlSisa
    With ThisWorkbook.Sheets("TbBarang")
    TBKODE.Value = .Cells(SBBRG, 1).Value
    TBNAMA.Value = .Cells(SBBRG, 2).Value
    TBSAT.Value = .Cells(SBBRG, 3).Value
    harga = .Cells(SBBRG.Value, 4).Value
    TBHARGA.Value = FormatNumber(harga, 2, vbUseDefault, vbUseDefault, vbUseDefault)
    OPYES.Value = .Cells(SBBRG, 5).Value
    OPNO.Value = Not .Cells(SBBRG, 5).Value
    On Error Resume Next
    With ThisWorkbook.Sheets("dummy")
    .Range("R:AC").Clear
    .Cells(1, 20).Value = "Kode Barang"
    .Cells(2, 20).Value = TBKODE.Value
    .Cells(1, 21).Value = "Jumlah"
    ThisWorkbook.Sheets("TbTrBarang").Unprotect
    .Cells(2, 21).Value = ">0"
    JmlMasuk = Application.WorksheetFunction.DSum(ThisWorkbook.Sheets("TbTrBarang").Range("A1").CurrentRegion, "Jumlah", ThisWorkbook.Sheets("dummy").Range("T1:U2"))
    TBMASUK = JmlMasuk
    .Cells(2, 21).Value = "<0"
    JmlKeluar = Application.WorksheetFunction.DSum(ThisWorkbook.Sheets("TbTrBarang").Range("A1").CurrentRegion, "Jumlah", ThisWorkbook.Sheets("dummy").Range("T1:U2"))
    TBKELUAR = -1 * JmlKeluar
    ThisWorkbook.Sheets("TbTrBarang").Protect
    JmlSisa = JmlMasuk + JmlKeluar
    TBSISA = JmlSisa
    If JmlSisa < 0 Then
    TBSISA.BackColor = &HFF&
    Else
    TBSISA.BackColor = &H80000010&
    End If
    End With
    On Error GoTo 0
    End With
    End Sub

    Makasih sebelumnya..

 

atau Mendaftar untuk ikut berdiskusi!