Purchase/Sales Form Macro Codes For Data Entry

Last updated on March 19th, 2021 at 06:24 am

This topic is the continuation of the “Purchase/Sales Data Entry Form” page. Here Mr. Adi will make a Purchase/Sales Form macro codes.

If my reader wants to directly jump to the test-run stage of the macro, please download the sample file in the second page of this topic.

Macro to set the size and the position of ActiveX control.

Still in the “CUSU” sheet and the Developer menu tab, if the Design Mode still active (orange color), please deactivate it by clicking it. And then click the Visual Basic button (in my Excel Application, the button is on the most left menu) to open the Visual Basic Editor.

From the image below, we can see that in the VB Editor left pane, there are two small windows, the “Project – VBAProject” window and the “Properties – Sheet5” window on the left side of the Editor.

In the “Project – VBAProject” window, double click the “Sheet5 (CUSU)” to make sure that the module (on the right pane) to write the macro is “CUSU” module.

Copy the macro codes below then paste them on the white blank module on the right pane. The result will look like the image above.

Dim rngItem         As Range
Dim cnt             As Integer

Sub SetActiveXControls()
    Set patok = Range("zz1")
    With CU
        .Height = patok.Height * 2 - 5
        .Width = patok.Width
        .Top = Range("h2").Top - 3
        .Left = Range("h2").Left
    End With
    With SU
        .Height = patok.Height * 2 - 5
        .Width = patok.Width
        .Top = Range("i2").Top - 3
        .Left = Range("i2").Left
    End With
    With Item
        .Height = patok.Height * 2 - 5
        .Width = patok.Width
        .Top = Range("j2").Top - 3
        .Left = Range("j2").Left
    End With
    With Kas_Bon
        .Height = patok.Height * 2 - 5
        .Width = patok.Width * 3
        .Top = Range("h4").Top - 8
        .Left = Range("h4").Left
    End With
    With SearchBox
        .Height = patok.Height + 5
        .Width = patok.Width * 2
        .Top = Range("i6").Top - 4
        .Left = Range("i6").Left
    End With
    With ListName
        .Height = patok.Height * 6 - 2
        .Width = patok.Width * 3
        .Top = Range("h7").Top
        .Left = Range("h7").Left
    End With
    With NewName
        .Height = patok.Height * 2 - 4
        .Width = patok.Width * 3
        .Top = Range("h13").Top
        .Left = Range("h13").Left
    End With
    With InputToData
        .Height = patok.Height * 2 + 5
        .Width = patok.Width * 3
        .Top = Range("h16").Top
        .Left = Range("h16").Left
    End With
End Sub

Put the cursor anywhere between the Sub SetActiveXControls line and the End Sub line. Then run the “SetActiveXControls” sub by clicking the “play” button located in the VB Editor menu. It is a small green triangle icon pointed out by the red arrow in the image above.

Minimize the VB Editor window to see the result on sheet “CUSU” after running this sub.

Next, Mr. Adi make sure that the cursor is under the End Sub text, as pointed out with the red arrow in the image below ….

then copy the codes below and paste them at the cursor.

Sub CU_Click()
    'ActiveSheet.Unprotect
    Application.EnableEvents = False
    SearchBox.Value = "": SearchBox.Activate: ListName.Clear
    Range("AA1").Value = "Customer"
    Range("E2").Value = Range("AA2").Value
    Range("E3").ClearContents
    CU.BackColor = &HC0C0FF
    SU.BackColor = &H8000000F&
    Item.BackColor = &H8000000F&
    NewName.Caption = "New Customer Name"
    Application.EnableEvents = True
    'ActiveSheet.Protect
End Sub

Sub SU_Click()
    'ActiveSheet.Unprotect
    Application.EnableEvents = False
    SearchBox.Value = "": SearchBox.Activate: ListName.Clear
    Range("AA1").Value = "Supplier"
    Range("E2").Value = Range("AA3").Value
    Range("E3").ClearContents
    CU.BackColor = &H8000000F&
    SU.BackColor = &HC0C0FF
    Item.BackColor = &H8000000F&
    Kas_Bon.BackColor = &HC0C0FF
    NewName.Caption = "New Supplier Name"
    Application.EnableEvents = True
    'ActiveSheet.Protect
End Sub

Private Sub ITEM_Click()
    'ActiveSheet.Unprotect
    Application.EnableEvents = False
    SearchBox.Value = "": SearchBox.Activate: ListName.Clear
    Range("AA1").Value = "Item"
    CU.BackColor = &H8000000F&
    SU.BackColor = &H8000000F&
    Item.BackColor = &HC0C0FF
    NewName.Caption = "New Item Name"
    Application.EnableEvents = True
    'ActiveSheet.Protect
End Sub

Private Sub Kas_Bon_Click()
    Kas_Bon.BackColor = &HC0C0FF
    If Kas_Bon.Caption = "CASH" Then _
    Kas_Bon.Caption = "NON CASH": Range("c17").Value = "Non CASH": Exit Sub
    If Kas_Bon.Caption = "NON CASH" Then _
    Kas_Bon.Caption = "CASH": Range("c17").Value = "CASH":
End Sub

Private Sub SearchBox_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Application.EnableEvents = False
SearchBox.Value = ""
Application.EnableEvents = True
End Sub

Private Sub SearchBox_Change()
Dim MyList As Variant, i As Long
    
    nm = Range("AA1").Value
    Set rng = Sheets("TABLE").Range(nm)
    
    MyList = Application.Transpose(rng)
    With ListName
        If SearchBox.Value = "" Then
            .Clear
            '.List = MyList
        Else
            .Clear
            For i = LBound(MyList, 1) To UBound(MyList, 1)
                If LCase(MyList(i)) Like "*" _
                & LCase(SearchBox.Value) _
                & "*" Then .AddItem MyList(i)
            Next i
        End If
    End With
    If ListName.ListCount = 1 Then ListName.Selected(0) = True
End Sub

Private Sub ListName_Click()
    'ActiveSheet.Unprotect
    Application.EnableEvents = False
    If Range("AA1").Value = "Item" Then
        Range("b20").End(xlUp).Offset(1, 0).Value = Me.ListName.Value
    Else
        Range("E3").Value = Me.ListName.Value
    End If
    'ActiveSheet.Protect
    Application.EnableEvents = True
End Sub

Private Sub NewName_Click()
    'ActiveSheet.unProtect
    X = Range("AA1").Value
    xName = InputBox("Type the new " + X + " name")
    If xName = "" Then Exit Sub

    Application.ScreenUpdating = False
    With Sheets("TABLE")
    If Not .Range(X).Find(xName, lookat:=xlWhole) Is Nothing Then
        MsgBox "The new name you typed already in the sheet TABLE"
        Exit Sub
    End If
    LR = .Range(X).Rows.Count + 1
    .Range(X)(LR, 1).Value = Application.Proper(xName)
    End With
    If X = "Item" Then
        Range("B20").End(xlUp).Offset(1, 0).Value = _
        Application.Proper(xName)
    Else
        Range("E3").Value = Application.Proper(xName)
    End If
    Application.ScreenUpdating = True
    'ActiveSheet.Protect
End Sub

Private Sub InputToData_Click()
    Set rngItem = Range("B7:B16")
    cnt = Application.CountA(rngItem)
    Set sh = Sheets("SellBuy")
    Set sdt = Sheets("DATA")
    
    'cek kesalahan
    Call CekKesalahan
    If Range("AA4").Value = "not oke" Then Exit Sub
    
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    'persiapan di halaman HARIAN dan halaman DATA
    idNota = Left(sh.Range("E2"), 9)
    Set rngKopi = Range("AA7").Resize(cnt, 13)
    Set awal = sdt.Range("B" & Rows.Count).End(xlUp).Offset(1, 0)
    Set rngPaste = awal.Resize(cnt, 13)
    
    'input ke halaman DATA dan BACKUP transaksi ini
    rngPaste.Value = rngKopi.Value
    
    'input KAS apabila CASH
    If Range("C17").Value = "CASH" Then
        Set lunas = sdt.Range("B" & Rows.Count).End(xlUp)
        lunas.Resize(1, 13).Copy
        lunas.Offset(1, 0).PasteSpecial (xlValues)
        lunas.Offset(1, 3).Value = "CASH"
        sdt.Range(lunas.Offset(1, 5), lunas.Offset(1, 7)).ClearContents
        lunas.Offset(1, 9).ClearContents
        If lunas.Offset(1, 4).Value = "CU" Then
            lunas.Offset(1, 8).Value = sh.Range("E17").Value
            lunas.Offset(1, 10).Value = "DEBIT"
        Else
            lunas.Offset(1, 8).Value = -sh.Range("E17").Value
            lunas.Offset(1, 10).Value = "CREDIT"
        End If
    End If
    
    'tampilkan pesan bahwa transaksi telah masuk data
    Application.ScreenUpdating = True
    sdt.Select
    rngPaste.Select
    ActiveWindow.ScrollRow = ActiveCell.Row
    MsgBox "Transaction already inputted to the Main Data"
    sh.Select
    
    'tambahin nomor nota
    Nomor = Format(Right(Range("E2"), 3)) + 1
    NomorNota = idNota + Format(Nomor, "000")
    Range("E2").Value = NomorNota
    
    'pindahin nomor nota ke helper
    If Left(NomorNota, 1) = "C" Then
        Range("AA2").Value = NomorNota
    Else
        Range("AA3").Value = NomorNota
    End If
    
    'bersihkan halaman HARIAN
    Range("E3,B7:D16").ClearContents
    SearchBox.Value = ""
    
    'refresh Pivot Table
    Sheets("CUSU").PivotTables("ptCUSU").PivotCache.Refresh
    
    Range("B7").Select
    
    Application.EnableEvents = True
    
    'save file nya
    'ActiveWorkbook.Save
End Sub

Private Sub CekKesalahan()
    'cek apakah masih ada kolom yang diperlukan tapi kosong
If Range("E1").Value = "" _
    Or Range("E2").Value = "" _
    Or Range("E3").Value = "" _
    Or cnt = 0 _
    Or Application.CountA(rngItem.Offset(0, 1)) <> cnt _
    Or Application.CountA(rngItem.Offset(0, 2)) <> cnt Then
    MsgBox "There is an empty needed cell"
    Range("AA4").Value = "not oke"
    Exit Sub
Else
    Range("AA4").Value = "oke"
End If

'cek apakah nomor nota yang akan di input sudah ada di data
Set c = Sheets("DATA").Columns(2).Find(Range("E2").Value, lookat:=xlWhole)
If Not c Is Nothing Then
    MsgBox "The Invoice number " + Range("E2").Value + " is already in the Main Data"
    Range("AA4").Value = "not oke"
    Exit Sub
Else
    Range("AA4").Value = "oke"
End If

End Sub

Private Sub Worksheet_Activate()
    Call SetActiveXControls
    Call tmpSellBuy
End Sub

Sub tmpSellBuy()
Application.EnableEvents = False
With Sheets("SellBuy")
Set rg = .Range("AA7:AA16")
rg.Offset(0, 0).Formula = "=$E$1"
rg.Offset(0, 1).Formula = "=$E$2"
rg.Offset(0, 2).Formula = "=$E$3"
rg.Offset(0, 3).Value = "STOCK"
rg.Offset(0, 4).Formula = _
"=IF(LEFT(AB7,1)=""C"",""CU"",""SU"")"
rg.Offset(0, 5).Formula = "=B7"
rg.Offset(0, 6).Formula = "=C7"
rg.Offset(0, 7).Formula = "=D7"
rg.Offset(0, 8).Formula = "=IF(AE7=""CU"",-E7,E7)"
rg.Offset(0, 9).Formula = "=IF(AE7=""CU"",-AG7,AG7)"
rg.Offset(0, 10).Formula = _
"=IF(AE7=""CU"",""CREDIT"",""DEBIT"")"
rg.Offset(0, 11).Formula = _
"=DATEVALUE(CONCATENATE(""01-"",MID(AB7,6,2),""-"",MID(AB7,4,2)))"
rg.Offset(0, 12).Formula = _
"=IF($C$17=""CASH"",CONCATENATE(TEXT(AA7,""yymm""),""PAID""),"""")"
End With
Application.EnableEvents = True
End Sub

Mr. Adi still add one more macro to have the invoice number reset to 001 when the file (Workbook) is opened for the first time on each day. This code will be put in the “ThisWorkbook” module.

In the “Project- VBAProject” window, double click the “ThisWorkbook” to open its module. Copy the macro below then paste it on the module.

Private Sub Workbook_Open()
Dim MaxDate As Date
MaxDate = WorksheetFunction. _
Max(Sheets("DATA").Range("B1:B50000"))
TglAkhir = Format(MaxDate, "yymmdd")
NomorPatok = Format(Date, "yymmdd")
If NomorPatok > TglAkhir Then
    idCU = "CU-"
    idSU = "SU-"
    With Sheets("SellBuy")
        '.Unprotect
        .Range("AA2").Value = idCU + NomorPatok + "001"
        .Range("AA3").Value = idSU + NomorPatok + "001"
        .Range("E2:E3").ClearContents
        '.Protect
        ActiveWorkbook.Save
    End With
    End If
End Sub

The result will look like the sample image below.

In order the form visualization is not plain, Mr. Adi make some column adjustment and color the cells according to his like. The process is not covered here because it’s just a personal taste.

In the next page, Mr. Adi will test-run his Purchase/Sales Form Macro for data entry to check whether it gives the result as expected or not.