Credit Invoice Management

[Muh]

Dear Sir
Good day. Here attached Excel work book . We Need to track Credit invoice in Customer Signature and Seal

1.ERP Data Sheet- This Data get from Erp
2.Data Entry Sheet- There is Drop down List In Column I3- Date . Date Select Automatically Pick Concerned Date Transaction
Need to Fill Manually Column "I" and "J"
Once all Concerned Date Invoice Data manually Fill ("Column I & J" ) then Click " Save" Button Then Data entry Filled Data Automatically Came Summary Sheet after Pressing "Clear" Button then Column "I and J" Data Remove

Please Can Sort This Problem

 

[shamimarita]

Hello Muh,

You will need to use VBA code to perform the tasks you mentioned.

Paste this VBA (Standard Module):

• Press Alt+F11 >> select Insert >> select Module.
• Paste the code below.

Option Explicit

'=== CONFIG (tailored to your file) ===
Const SH_ERP As String = "ERP DATA"
Const SH_ENTRY As String = "Data Entry"
Const SH_SUM As String = "Summary"
Const ENTRY_DATE_CELL As String = "I3"

' NOTE: Your workbook header "Customer Signature" has a trailing space:
Const H_DATE As String = "Date"
Const H_VOUCHER As String = "Voucher"
Const H_ACCOUNT As String = "Account"
Const H_CR As String = "Cr (base)"
Const H_MEMBER As String = "Member Name"
Const H_EMP As String = "Employee Name"
Const H_SIG As String = "Customer Signature " ' <-- trailing space
Const H_SEAL As String = "Seal"

'=== Utilities ===
Private Function FindHeaderCell(ws As Worksheet, headerText As String) As Range
    Dim r As Range, c As Range
    Set r = ws.Range("A1:P25") ' search top-left block
    For Each c In r
        If CStr(c.Value) = headerText Then
            Set FindHeaderCell = c
            Exit Function
        End If
    Next c
End Function

Private Function LastRowIn(ws As Worksheet, Optional col As Long = 1) As Long
    With ws
        LastRowIn = .Cells(.Rows.Count, col).End(xlUp).Row
    End With
End Function

Private Function ExistsInColumn(colRng As Range, keyVal As Variant) As Boolean
    If colRng Is Nothing Then
        ExistsInColumn = False
    Else
        ExistsInColumn = Not IsError(Application.Match(keyVal, colRng, 0))
    End If
End Function

'=== 1) Load ERP rows for selected date into Data Entry ===
Public Sub Load_By_Date_Range()
    Dim wsE As Worksheet, ws As Worksheet
    Dim hE_Date As Range, hE_Vou As Range, hE_Acc As Range, hE_Cr As Range
    Dim hN_Date As Range, hN_Vou As Range, hN_Acc As Range, hN_Cr As Range
    Dim dt As Date, r As Long, lastE As Long, writeRow As Long
    Dim vDate, vVou, vAcc, vCr
    
    Set wsE = ThisWorkbook.Worksheets(SH_ERP)
    Set ws = ThisWorkbook.Worksheets(SH_ENTRY)
    If Not IsDate(ws.Range(ENTRY_DATE_CELL).Value) Then
        MsgBox "Pick a valid date in " & ENTRY_DATE_CELL, vbExclamation: Exit Sub
    End If
    dt = CDate(ws.Range(ENTRY_DATE_CELL).Value)
    
    ' find headers
    Set hE_Date = FindHeaderCell(wsE, H_DATE)
    Set hE_Vou  = FindHeaderCell(wsE, H_VOUCHER)
    Set hE_Acc  = FindHeaderCell(wsE, H_ACCOUNT)
    Set hE_Cr   = FindHeaderCell(wsE, H_CR)
    Set hN_Date = FindHeaderCell(ws, H_DATE)
    Set hN_Vou  = FindHeaderCell(ws, H_VOUCHER)
    Set hN_Acc  = FindHeaderCell(ws, H_ACCOUNT)
    Set hN_Cr   = FindHeaderCell(ws, H_CR)
    If hE_Date Is Nothing Or hN_Date Is Nothing Then
        MsgBox "Couldn't find headers. Keep header texts exactly as in your sheets.", vbCritical: Exit Sub
    End If
    
    ' clear current rows under the blue header
    Dim firstEntryRow As Long, lastEntryRow As Long
    firstEntryRow = hN_Date.Row + 1
    lastEntryRow = LastRowIn(ws, hN_Date.Column)
    If lastEntryRow >= firstEntryRow Then
        ws.Range(ws.Cells(firstEntryRow, hN_Date.Column), ws.Cells(lastEntryRow, hN_Cr.Column)).ClearContents
        ws.Range(ws.Cells(firstEntryRow, hN_Cr.Column + 1), ws.Cells(lastEntryRow, hN_Cr.Column + 4)).ClearContents ' G:J
    End If
    
    ' copy matching rows (works even if ERP dates have time)
    writeRow = firstEntryRow
    lastE = LastRowIn(wsE, hE_Date.Column)
    For r = hE_Date.Row + 1 To lastE
        vDate = wsE.Cells(r, hE_Date.Column).Value
        If IsDate(vDate) Then
            If CLng(CDate(vDate)) >= CLng(dt) And CLng(CDate(vDate)) < CLng(dt + 1) Then
                vVou = wsE.Cells(r, hE_Vou.Column).Value
                vAcc = wsE.Cells(r, hE_Acc.Column).Value
                vCr  = wsE.Cells(r, hE_Cr.Column).Value
                ws.Cells(writeRow, hN_Date.Column).Value = vDate
                ws.Cells(writeRow, hN_Vou.Column).Value  = vVou
                ws.Cells(writeRow, hN_Acc.Column).Value  = vAcc
                ws.Cells(writeRow, hN_Cr.Column).Value   = vCr
                writeRow = writeRow + 1
            End If
        End If
    Next r
    
    If writeRow = firstEntryRow Then
        MsgBox "No ERP rows for " & Format(dt, "dd-mmm-yyyy") & ".", vbInformation
    End If
End Sub

'=== 2) Save Entry rows to Summary (require Signature & Seal; skip duplicate Voucher) ===
Public Sub Save_Entry_To_Summary_Range()
    Dim ws As Worksheet, wsS As Worksheet
    Dim hN_Date As Range, hN_Vou As Range, hN_Acc As Range, hN_Cr As Range
    Dim hN_Mem As Range, hN_Emp As Range, hN_Sig As Range, hN_Seal As Range
    Dim hS_Date As Range, hS_Vou As Range, hS_Acc As Range, hS_Cr As Range
    Dim hS_Mem As Range, hS_Emp As Range, hS_Sig As Range, hS_Seal As Range
    Dim r As Long, firstRow As Long, lastRow As Long, wr As Long, keyVal, sumKeyRng As Range
    
    Set ws = ThisWorkbook.Worksheets(SH_ENTRY)
    Set wsS = ThisWorkbook.Worksheets(SH_SUM)
    
    ' locate headers
    Set hN_Date = FindHeaderCell(ws, H_DATE)
    Set hN_Vou  = FindHeaderCell(ws, H_VOUCHER)
    Set hN_Acc  = FindHeaderCell(ws, H_ACCOUNT)
    Set hN_Cr   = FindHeaderCell(ws, H_CR)
    Set hN_Mem  = FindHeaderCell(ws, H_MEMBER)
    Set hN_Emp  = FindHeaderCell(ws, H_EMP)
    Set hN_Sig  = FindHeaderCell(ws, H_SIG)
    Set hN_Seal = FindHeaderCell(ws, H_SEAL)
    Set hS_Date = FindHeaderCell(wsS, H_DATE)
    Set hS_Vou  = FindHeaderCell(wsS, H_VOUCHER)
    Set hS_Acc  = FindHeaderCell(wsS, H_ACCOUNT)
    Set hS_Cr   = FindHeaderCell(wsS, H_CR)
    Set hS_Mem  = FindHeaderCell(wsS, H_MEMBER)
    Set hS_Emp  = FindHeaderCell(wsS, H_EMP)
    Set hS_Sig  = FindHeaderCell(wsS, H_SIG)
    Set hS_Seal = FindHeaderCell(wsS, H_SEAL)
    If hN_Sig Is Nothing Then
        MsgBox "Header 'Customer Signature ' (with trailing space) not found on 'Data Entry'.", vbCritical: Exit Sub
    End If
    
    ' validate Signature & Seal
    firstRow = hN_Date.Row + 1
    lastRow = LastRowIn(ws, hN_Date.Column)
    If lastRow < firstRow Then MsgBox "Nothing to save.", vbInformation: Exit Sub
    For r = firstRow To lastRow
        If Len(Trim$(ws.Cells(r, hN_Vou.Column).Value)) > 0 Then
            If Len(Trim$(ws.Cells(r, hN_Sig.Column).Value)) = 0 Or Len(Trim$(ws.Cells(r, hN_Seal.Column).Value)) = 0 Then
                MsgBox "Please fill 'Customer Signature' and 'Seal' for all rows.", vbExclamation: Exit Sub
            End If
        End If
    Next r
    
    ' existing Voucher keys in Summary (for dedupe)
    If LastRowIn(wsS, hS_Vou.Column) >= hS_Vou.Row + 1 Then
        Set sumKeyRng = wsS.Range(wsS.Cells(hS_Vou.Row + 1, hS_Vou.Column), _
                                  wsS.Cells(LastRowIn(wsS, hS_Vou.Column), hS_Vou.Column))
    End If
    
    ' append non-duplicates
    wr = Application.Max(hS_Date.Row + 1, LastRowIn(wsS, hS_Date.Column) + 1)
    For r = firstRow To lastRow
        If Len(Trim$(ws.Cells(r, hN_Vou.Column).Value)) > 0 Then
            keyVal = ws.Cells(r, hN_Vou.Column).Value
            If Not ExistsInColumn(sumKeyRng, keyVal) Then
                wsS.Cells(wr, hS_Date.Column).Value = ws.Cells(r, hN_Date.Column).Value
                wsS.Cells(wr, hS_Vou.Column).Value  = ws.Cells(r, hN_Vou.Column).Value
                wsS.Cells(wr, hS_Acc.Column).Value  = ws.Cells(r, hN_Acc.Column).Value
                wsS.Cells(wr, hS_Cr.Column).Value   = ws.Cells(r, hN_Cr.Column).Value
                wsS.Cells(wr, hS_Mem.Column).Value  = ws.Cells(r, hN_Mem.Column).Value
                wsS.Cells(wr, hS_Emp.Column).Value  = ws.Cells(r, hN_Emp.Column).Value
                wsS.Cells(wr, hS_Sig.Column).Value  = ws.Cells(r, hN_Sig.Column).Value
                wsS.Cells(wr, hS_Seal.Column).Value = ws.Cells(r, hN_Seal.Column).Value
                wr = wr + 1
            End If
        End If
    Next r
    
    MsgBox "Saved to Summary.", vbInformation
End Sub

'=== 3) Clear Signature & Seal in Data Entry ===
Public Sub Clear_Signature_Seal()
    Dim ws As Worksheet, hN_Sig As Range, hN_Seal As Range, firstRow As Long, lastRow As Long
    Set ws = ThisWorkbook.Worksheets(SH_ENTRY)
    Set hN_Sig = FindHeaderCell(ws, H_SIG)
    Set hN_Seal = FindHeaderCell(ws, H_SEAL)
    If hN_Sig Is Nothing Or hN_Seal Is Nothing Then Exit Sub
    firstRow = hN_Sig.Row + 1
    lastRow = LastRowIn(ws, hN_Sig.Column)
    If lastRow >= firstRow Then
        ws.Range(ws.Cells(firstRow, hN_Sig.Column), ws.Cells(lastRow, hN_Seal.Column)).ClearContents
    End If
End Sub

Auto-load when the date changes

• Right-click the Data Entry tab → View Code → paste this in that sheet’s module:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Me.Range("I3")) Is Nothing Then
        Application.EnableEvents = False
        Load_By_Date_Range
        Application.EnableEvents = True
    End If
End Sub

Hook up your buttons:

• SAVE button >> assign macro: Save_Entry_To_Summary_Range
• CLEAR button >> assign macro: Clear_Signature_Seal
• (If no auto-load) add a Load button >> Load_By_Date_Range

Notes specific to your file

• Headers must match exactly. In your file, the header is Customer Signature (notice the trailing space). Either keep it that way, or rename it to remove the space and update the constant H_SIG in the code.
• Deduplication uses Voucher. Change that by editing H_VOUCHER.

 

[Muh]

Sir
Thanks for your Prompt Response . Can you Please Let to Set File With This VBA Code Step by step . We Try to Add in File But not Working

 

[indria]

Pak,
Terima kasih atas respon cepatnya. Bisakah membantu saya mengatur file dengan kode VBA ini langkah demi langkah? Kami mencoba menambahkannya ke dalam file, tetapi tidak berhasil.

 

[shamimarita]

Hello,

Thanks for the quick follow-up. Here’s exactly how to wire the file so the macros work.

Make a backup: Save a copy first.

Save as macro workbook

• File → Save As → choose Excel Macro-Enabled Workbook (*.xlsm).

Paste the VBA (Standard Module)

1. Press Alt+F11 → Insert → Module.
2. Paste the entire code blockyou were given (it includes the helpers like FindHeaderCell, LastRowIn, etc.).
   • The three macro names you’ll see are:
     • Load_By_Date_Range
     • Save_Entry_To_Summary_Range
     • Clear_Signature_Seal

If you get “Sub or Function not defined,” it means a helper function wasn’t pasted—please paste the full code.

Add the Small Event (Sheet code)

This is the most common setup miss.

1. In the Project pane (left), double-click the sheet named “Data Entry” (not a module).
2. Paste this tiny event code there:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Me.Range("I3")) Is Nothing Then
Application.EnableEvents = False
Load_By_Date_Range
Application.EnableEvents = True
End If
End Sub

This makes the rows load automatically whenever you change the date in I3.