{"id":1514,"date":"2021-03-17T03:55:26","date_gmt":"2021-03-16T19:55:26","guid":{"rendered":"https:\/\/indonesiangems.com\/blog\/?p=1514"},"modified":"2021-03-19T06:24:28","modified_gmt":"2021-03-18T22:24:28","slug":"excel-macro-purchase-sales-form-data-entry","status":"publish","type":"post","link":"https:\/\/indonesiangems.com\/blog\/excel-macro-purchase-sales-form-data-entry\/","title":{"rendered":"Purchase\/Sales Form Macro Codes For Data Entry"},"content":{"rendered":"

Last updated on March 19th, 2021 at 06:24 am<\/p>\n\n\n\n\n

\n
switch language to bahasa<\/a><\/div>\n<\/div>\n\n\n\n

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

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.<\/p>\n\n\n\n

Macro to set the size and the position of ActiveX control<\/em>.<\/h5>\n\n\n\n
\"\"<\/a><\/figure><\/div>\n\n\n\n

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.<\/p>\n\n\n\n

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.<\/p>\n\n\n\n

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.<\/p>\n\n\n\n

\"\"<\/a><\/figure><\/div>\n\n\n\n

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.<\/p>\n\n\n\n

Dim rngItem         As Range\nDim cnt             As Integer\n\nSub SetActiveXControls()\n    Set patok = Range(\"zz1\")\n    With CU\n        .Height = patok.Height * 2 - 5\n        .Width = patok.Width\n        .Top = Range(\"h2\").Top - 3\n        .Left = Range(\"h2\").Left\n    End With\n    With SU\n        .Height = patok.Height * 2 - 5\n        .Width = patok.Width\n        .Top = Range(\"i2\").Top - 3\n        .Left = Range(\"i2\").Left\n    End With\n    With Item\n        .Height = patok.Height * 2 - 5\n        .Width = patok.Width\n        .Top = Range(\"j2\").Top - 3\n        .Left = Range(\"j2\").Left\n    End With\n    With Kas_Bon\n        .Height = patok.Height * 2 - 5\n        .Width = patok.Width * 3\n        .Top = Range(\"h4\").Top - 8\n        .Left = Range(\"h4\").Left\n    End With\n    With SearchBox\n        .Height = patok.Height + 5\n        .Width = patok.Width * 2\n        .Top = Range(\"i6\").Top - 4\n        .Left = Range(\"i6\").Left\n    End With\n    With ListName\n        .Height = patok.Height * 6 - 2\n        .Width = patok.Width * 3\n        .Top = Range(\"h7\").Top\n        .Left = Range(\"h7\").Left\n    End With\n    With NewName\n        .Height = patok.Height * 2 - 4\n        .Width = patok.Width * 3\n        .Top = Range(\"h13\").Top\n        .Left = Range(\"h13\").Left\n    End With\n    With InputToData\n        .Height = patok.Height * 2 + 5\n        .Width = patok.Width * 3\n        .Top = Range(\"h16\").Top\n        .Left = Range(\"h16\").Left\n    End With\nEnd Sub<\/code><\/pre>\n\n\n\n
Put the cursor anywhere between the Sub SetActiveXControls<\/span> line and the End Sub<\/span> 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.<\/p>\n\n\n\n
Minimize the VB Editor window to see the result on sheet “CUSU” after running this sub.<\/p>\n\n\n\n
\"\"<\/a>
The size and the position of the controls now are not messy anymore<\/em>
(please ignore the foreign name in the image)<\/em><\/figcaption><\/figure><\/div>\n\n\n\n
Next, Mr. Adi make sure that the cursor is under the End Sub<\/span> text, as pointed out with the red arrow in the image below ….<\/p>\n\n\n\n
\"\"<\/a><\/figure><\/div>\n\n\n\n
then copy the codes below and paste them at the cursor.<\/p>\n\n\n\n
Sub CU_Click()\n    'ActiveSheet.Unprotect\n    Application.EnableEvents = False\n    SearchBox.Value = \"\": SearchBox.Activate: ListName.Clear\n    Range(\"AA1\").Value = \"Customer\"\n    Range(\"E2\").Value = Range(\"AA2\").Value\n    Range(\"E3\").ClearContents\n    CU.BackColor = &HC0C0FF\n    SU.BackColor = &H8000000F&\n    Item.BackColor = &H8000000F&\n    NewName.Caption = \"New Customer Name\"\n    Application.EnableEvents = True\n    'ActiveSheet.Protect\nEnd Sub\n\nSub SU_Click()\n    'ActiveSheet.Unprotect\n    Application.EnableEvents = False\n    SearchBox.Value = \"\": SearchBox.Activate: ListName.Clear\n    Range(\"AA1\").Value = \"Supplier\"\n    Range(\"E2\").Value = Range(\"AA3\").Value\n    Range(\"E3\").ClearContents\n    CU.BackColor = &H8000000F&\n    SU.BackColor = &HC0C0FF\n    Item.BackColor = &H8000000F&\n    Kas_Bon.BackColor = &HC0C0FF\n    NewName.Caption = \"New Supplier Name\"\n    Application.EnableEvents = True\n    'ActiveSheet.Protect\nEnd Sub\n\nPrivate Sub ITEM_Click()\n    'ActiveSheet.Unprotect\n    Application.EnableEvents = False\n    SearchBox.Value = \"\": SearchBox.Activate: ListName.Clear\n    Range(\"AA1\").Value = \"Item\"\n    CU.BackColor = &H8000000F&\n    SU.BackColor = &H8000000F&\n    Item.BackColor = &HC0C0FF\n    NewName.Caption = \"New Item Name\"\n    Application.EnableEvents = True\n    'ActiveSheet.Protect\nEnd Sub\n\nPrivate Sub Kas_Bon_Click()\n    Kas_Bon.BackColor = &HC0C0FF\n    If Kas_Bon.Caption = \"CASH\" Then _\n    Kas_Bon.Caption = \"NON CASH\": Range(\"c17\").Value = \"Non CASH\": Exit Sub\n    If Kas_Bon.Caption = \"NON CASH\" Then _\n    Kas_Bon.Caption = \"CASH\": Range(\"c17\").Value = \"CASH\":\nEnd Sub\n\nPrivate Sub SearchBox_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)\nApplication.EnableEvents = False\nSearchBox.Value = \"\"\nApplication.EnableEvents = True\nEnd Sub\n\nPrivate Sub SearchBox_Change()\nDim MyList As Variant, i As Long\n    \n    nm = Range(\"AA1\").Value\n    Set rng = Sheets(\"TABLE\").Range(nm)\n    \n    MyList = Application.Transpose(rng)\n    With ListName\n        If SearchBox.Value = \"\" Then\n            .Clear\n            '.List = MyList\n        Else\n            .Clear\n            For i = LBound(MyList, 1) To UBound(MyList, 1)\n                If LCase(MyList(i)) Like \"*\" _\n                & LCase(SearchBox.Value) _\n                & \"*\" Then .AddItem MyList(i)\n            Next i\n        End If\n    End With\n    If ListName.ListCount = 1 Then ListName.Selected(0) = True\nEnd Sub\n\nPrivate Sub ListName_Click()\n    'ActiveSheet.Unprotect\n    Application.EnableEvents = False\n    If Range(\"AA1\").Value = \"Item\" Then\n        Range(\"b20\").End(xlUp).Offset(1, 0).Value = Me.ListName.Value\n    Else\n        Range(\"E3\").Value = Me.ListName.Value\n    End If\n    'ActiveSheet.Protect\n    Application.EnableEvents = True\nEnd Sub\n\nPrivate Sub NewName_Click()\n    'ActiveSheet.unProtect\n    X = Range(\"AA1\").Value\n    xName = InputBox(\"Type the new \" + X + \" name\")\n    If xName = \"\" Then Exit Sub\n\n    Application.ScreenUpdating = False\n    With Sheets(\"TABLE\")\n    If Not .Range(X).Find(xName, lookat:=xlWhole) Is Nothing Then\n        MsgBox \"The new name you typed already in the sheet TABLE\"\n        Exit Sub\n    End If\n    LR = .Range(X).Rows.Count + 1\n    .Range(X)(LR, 1).Value = Application.Proper(xName)\n    End With\n    If X = \"Item\" Then\n        Range(\"B20\").End(xlUp).Offset(1, 0).Value = _\n        Application.Proper(xName)\n    Else\n        Range(\"E3\").Value = Application.Proper(xName)\n    End If\n    Application.ScreenUpdating = True\n    'ActiveSheet.Protect\nEnd Sub\n\nPrivate Sub InputToData_Click()\n    Set rngItem = Range(\"B7:B16\")\n    cnt = Application.CountA(rngItem)\n    Set sh = Sheets(\"SellBuy\")\n    Set sdt = Sheets(\"DATA\")\n    \n    'cek kesalahan\n    Call CekKesalahan\n    If Range(\"AA4\").Value = \"not oke\" Then Exit Sub\n    \n    Application.EnableEvents = False\n    Application.ScreenUpdating = False\n    \n    'persiapan di halaman HARIAN dan halaman DATA\n    idNota = Left(sh.Range(\"E2\"), 9)\n    Set rngKopi = Range(\"AA7\").Resize(cnt, 13)\n    Set awal = sdt.Range(\"B\" & Rows.Count).End(xlUp).Offset(1, 0)\n    Set rngPaste = awal.Resize(cnt, 13)\n    \n    'input ke halaman DATA dan BACKUP transaksi ini\n    rngPaste.Value = rngKopi.Value\n    \n    'input KAS apabila CASH\n    If Range(\"C17\").Value = \"CASH\" Then\n        Set lunas = sdt.Range(\"B\" & Rows.Count).End(xlUp)\n        lunas.Resize(1, 13).Copy\n        lunas.Offset(1, 0).PasteSpecial (xlValues)\n        lunas.Offset(1, 3).Value = \"CASH\"\n        sdt.Range(lunas.Offset(1, 5), lunas.Offset(1, 7)).ClearContents\n        lunas.Offset(1, 9).ClearContents\n        If lunas.Offset(1, 4).Value = \"CU\" Then\n            lunas.Offset(1, 8).Value = sh.Range(\"E17\").Value\n            lunas.Offset(1, 10).Value = \"DEBIT\"\n        Else\n            lunas.Offset(1, 8).Value = -sh.Range(\"E17\").Value\n            lunas.Offset(1, 10).Value = \"CREDIT\"\n        End If\n    End If\n    \n    'tampilkan pesan bahwa transaksi telah masuk data\n    Application.ScreenUpdating = True\n    sdt.Select\n    rngPaste.Select\n    ActiveWindow.ScrollRow = ActiveCell.Row\n    MsgBox \"Transaction already inputted to the Main Data\"\n    sh.Select\n    \n    'tambahin nomor nota\n    Nomor = Format(Right(Range(\"E2\"), 3)) + 1\n    NomorNota = idNota + Format(Nomor, \"000\")\n    Range(\"E2\").Value = NomorNota\n    \n    'pindahin nomor nota ke helper\n    If Left(NomorNota, 1) = \"C\" Then\n        Range(\"AA2\").Value = NomorNota\n    Else\n        Range(\"AA3\").Value = NomorNota\n    End If\n    \n    'bersihkan halaman HARIAN\n    Range(\"E3,B7:D16\").ClearContents\n    SearchBox.Value = \"\"\n    \n    'refresh Pivot Table\n    Sheets(\"CUSU\").PivotTables(\"ptCUSU\").PivotCache.Refresh\n    \n    Range(\"B7\").Select\n    \n    Application.EnableEvents = True\n    \n    'save file nya\n    'ActiveWorkbook.Save\nEnd Sub\n\nPrivate Sub CekKesalahan()\n    'cek apakah masih ada kolom yang diperlukan tapi kosong\nIf Range(\"E1\").Value = \"\" _\n    Or Range(\"E2\").Value = \"\" _\n    Or Range(\"E3\").Value = \"\" _\n    Or cnt = 0 _\n    Or Application.CountA(rngItem.Offset(0, 1)) <> cnt _\n    Or Application.CountA(rngItem.Offset(0, 2)) <> cnt Then\n    MsgBox \"There is an empty needed cell\"\n    Range(\"AA4\").Value = \"not oke\"\n    Exit Sub\nElse\n    Range(\"AA4\").Value = \"oke\"\nEnd If\n\n'cek apakah nomor nota yang akan di input sudah ada di data\nSet c = Sheets(\"DATA\").Columns(2).Find(Range(\"E2\").Value, lookat:=xlWhole)\nIf Not c Is Nothing Then\n    MsgBox \"The Invoice number \" + Range(\"E2\").Value + \" is already in the Main Data\"\n    Range(\"AA4\").Value = \"not oke\"\n    Exit Sub\nElse\n    Range(\"AA4\").Value = \"oke\"\nEnd If\n\nEnd Sub\n\nPrivate Sub Worksheet_Activate()\n    Call SetActiveXControls\n    Call tmpSellBuy\nEnd Sub\n\nSub tmpSellBuy()\nApplication.EnableEvents = False\nWith Sheets(\"SellBuy\")\nSet rg = .Range(\"AA7:AA16\")\nrg.Offset(0, 0).Formula = \"=$E$1\"\nrg.Offset(0, 1).Formula = \"=$E$2\"\nrg.Offset(0, 2).Formula = \"=$E$3\"\nrg.Offset(0, 3).Value = \"STOCK\"\nrg.Offset(0, 4).Formula = _\n\"=IF(LEFT(AB7,1)=\"\"C\"\",\"\"CU\"\",\"\"SU\"\")\"\nrg.Offset(0, 5).Formula = \"=B7\"\nrg.Offset(0, 6).Formula = \"=C7\"\nrg.Offset(0, 7).Formula = \"=D7\"\nrg.Offset(0, 8).Formula = \"=IF(AE7=\"\"CU\"\",-E7,E7)\"\nrg.Offset(0, 9).Formula = \"=IF(AE7=\"\"CU\"\",-AG7,AG7)\"\nrg.Offset(0, 10).Formula = _\n\"=IF(AE7=\"\"CU\"\",\"\"CREDIT\"\",\"\"DEBIT\"\")\"\nrg.Offset(0, 11).Formula = _\n\"=DATEVALUE(CONCATENATE(\"\"01-\"\",MID(AB7,6,2),\"\"-\"\",MID(AB7,4,2)))\"\nrg.Offset(0, 12).Formula = _\n\"=IF($C$17=\"\"CASH\"\",CONCATENATE(TEXT(AA7,\"\"yymm\"\"),\"\"PAID\"\"),\"\"\"\")\"\nEnd With\nApplication.EnableEvents = True\nEnd Sub\n\n<\/code><\/pre>\n\n\n\n
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.<\/p>\n\n\n\n
In the “Project- VBAProject” window, double click the “ThisWorkbook” to open its module. Copy the macro below then paste it on the module.<\/p>\n\n\n\n
Private Sub Workbook_Open()\nDim MaxDate As Date\nMaxDate = WorksheetFunction. _\nMax(Sheets(\"DATA\").Range(\"B1:B50000\"))\nTglAkhir = Format(MaxDate, \"yymmdd\")\nNomorPatok = Format(Date, \"yymmdd\")\nIf NomorPatok > TglAkhir Then\n    idCU = \"CU-\"\n    idSU = \"SU-\"\n    With Sheets(\"SellBuy\")\n        '.Unprotect\n        .Range(\"AA2\").Value = idCU + NomorPatok + \"001\"\n        .Range(\"AA3\").Value = idSU + NomorPatok + \"001\"\n        .Range(\"E2:E3\").ClearContents\n        '.Protect\n        ActiveWorkbook.Save\n    End With\n    End If\nEnd Sub<\/code><\/pre>\n\n\n\n
The result will look like the sample image below.<\/p>\n\n\n\n
\"\"<\/a><\/figure><\/div>\n\n\n\n
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.<\/p>\n\n\n\n
\"\"<\/figure><\/div>\n\n\n\n
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.<\/p>\n\n\n\n\n\n\n\n
TEST RUN<\/h5>\n\n\n\n
Mr. Adi saves the file first, close the file, then open it again.<\/p>\n\n\n\n
Assumed that the date is 8 March 2021 and it is the first time he open the file on this day. So, when the CU button is clicked, it will show the invoice number like this : CU-210308001. When the SU button is clicked, it will show SU-210308001.<\/p>\n\n\n\n
\"\"<\/figure>\n\n\n\n
CU\/SU is the indicator that it is a sales invoice or a purchase invoice. 210308 is the date format YYMMDD. And the 001 is the invoice number.<\/p>\n\n\n\n