Help Require to Create VBA Macro to Import Sales Transaction from Excel to Tally Prime

Dear All
Greetings for the day!!!

I have attached an Excel File having VBA Macro which Imports Sales Transaction from Excel to to tally on Clicking the Button having VBA Macro

everything is working fine but it supports Voucher having only Single Inventory Item details
i need your help in Importing Voucher Having Multiple item Details...

i have tried but not getting proper result

Thanks if any body can help

 

i am not able to upload the VBA Macro enable xl file so uploading Normal Excel file and Macro file seperately

 

Thanks Mr Amit for immediate response

Some how I sorted the issue

I will share working VBA code for others reference

 

Hi Everyone the following code is working fine to Import Excel to Tally Sales Transactions with Inventory and gst details
if it helps somebody


Option Explicit

'==================== CONFIG ====================
Private Const VOUCHER_TYPE As String = "Sales Dummy"
Private Const BATCH_GODOWN As String = "Solutions Computers"
Private Const BATCH_NAME As String = "Primary Batch"
Private Const DEFAULT_COMPANY_STATE As String = "Maharashtra"

'==================== HELPERS ====================
Private Function NormKey(ByVal s As String) As String
Dim i As Long, ch As String
s = LCase$(Trim$(CStr(s)))
For i = 1 To Len(s)
ch = Mid$(s, i, 1)
If ch Like "[a-z0-9]" Then NormKey = NormKey & ch
Next i
End Function

Private Function FindHeaderCol(ws As Worksheet, ParamArray candidates() As Variant) As Long
Dim lastCol As Long, c As Long, k As Variant, cellValue As String
lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
For Each k In candidates
For c = 1 To lastCol
cellValue = ""
If Not IsError(ws.Cells(1, c).Value) Then cellValue = CStr(ws.Cells(1, c).Value)
If NormKey(cellValue) = NormKey(CStr(k)) Then
FindHeaderCol = c
Exit Function
End If
Next c
Next k
FindHeaderCol = 0
End Function

Private Function GetSheetCI(ParamArray names() As Variant) As Worksheet
Dim wb As Workbook: Set wb = ThisWorkbook
Dim s As Worksheet, target As Variant, want As String
For Each target In names
want = NormKey(CStr(target))
For Each s In wb.Worksheets
If NormKey(s.Name) = want Then Set GetSheetCI = s: Exit Function
Next s
Next target
Set GetSheetCI = Nothing
End Function

Private Function GetSettingValue(ByVal key As String, Optional ByVal defaultValue As String = "") As String
Dim ws As Worksheet, lastRow As Long, r As Long
Set ws = GetSheetCI("settings")
If ws Is Nothing Then GetSettingValue = defaultValue: Exit Function
lastRow = ws.Cells(ws.rows.Count, 1).End(xlUp).row
For r = 1 To lastRow
If Trim$(CStr(ws.Cells(r, 1).Value)) = key Then
GetSettingValue = Trim$(CStr(ws.Cells(r, 2).Value))
Exit Function
End If
Next r
GetSettingValue = defaultValue
End Function

Private Function XmlEsc(ByVal s As String) As String
If LenB(s) = 0 Then XmlEsc = "": Exit Function
XmlEsc = Replace(Replace(Replace(Replace(Replace(s, "&", "&amp;"), "<", "&lt;"), ">", "&gt;"), """", "&quot;"), "'", "&apos;")
End Function

Private Function FmtAmt(ByVal v As Double) As String
FmtAmt = Replace(Format$(v, "0.00"), ",", "")
End Function

Private Function TallyDate(ByVal v As Variant) As String
Dim d As Date
On Error Resume Next
If IsDate(v) Then d = CDate(v) Else d = DateValue(CStr(v))
On Error GoTo 0
TallyDate = Format$(d, "yyyymmdd")
End Function

'==================== LedgerMap lookup ====================
Private Function GetLedgerForRate(gstRate As Double, ledgerType As String) As String
Dim ws As Worksheet, lastRow As Long, r As Long
Dim cRate As Long, cSales As Long, cCGST As Long, cSGST As Long, cIGST As Long

Set ws = GetSheetCI("LedgerMap")
If ws Is Nothing Then GetLedgerForRate = "": Exit Function

lastRow = ws.Cells(ws.rows.Count, 1).End(xlUp).row
cRate = FindHeaderCol(ws, "Gst %", "GST %", "Gst%", "GST Rate", "Item Gst %")
cSales = FindHeaderCol(ws, "Sales Ledger", "SalesLedger")
cCGST = FindHeaderCol(ws, "CGST Ledger", "Cgst Ledger", "Csgst Ledger", "CGST")
cSGST = FindHeaderCol(ws, "SGST Ledger", "Sgst Ledger", "SGST")
cIGST = FindHeaderCol(ws, "IGST Ledger", "Igst Ledger", "IGST")

For r = 2 To lastRow
If CDbl(Val(ws.Cells(r, cRate).Value)) = CDbl(gstRate) Then
Select Case UCase$(ledgerType)
Case "SALES": GetLedgerForRate = Trim$(CStr(ws.Cells(r, cSales).Value))
Case "CGST": GetLedgerForRate = Trim$(CStr(ws.Cells(r, cCGST).Value))
Case "SGST": GetLedgerForRate = Trim$(CStr(ws.Cells(r, cSGST).Value))
Case "IGST": GetLedgerForRate = Trim$(CStr(ws.Cells(r, cIGST).Value))
End Select
Exit Function
End If
Next r
GetLedgerForRate = ""
End Function

'==================== MAIN ====================
Sub ExportSalesToTallyXML()
Dim ws As Worksheet
Set ws = GetSheetCI("SALESDATA", "SalesData")
If ws Is Nothing Then
MsgBox "Sheet 'SALESDATA' not found.", vbCritical
Exit Sub
End If

' --- Header Columns ---
Dim colVNo As Long, colDate As Long, colParty As Long, colState As Long, colGSTIN As Long
Dim colItem As Long, colQty As Long, colRate As Long, colGstPct As Long
Dim colHSN As Long, colIRN As Long, colAck As Long

colVNo = FindHeaderCol(ws, "Voucher No", "VoucherNo")
colDate = FindHeaderCol(ws, "date", "Date")
colParty = FindHeaderCol(ws, "Prty name", "Party Name", "Party")
colState = FindHeaderCol(ws, "state", "State")
colGSTIN = FindHeaderCol(ws, "gstin", "GSTIN")
colItem = FindHeaderCol(ws, "itemname", "Item Name", "item")
colQty = FindHeaderCol(ws, "qty", "Quantity")
colRate = FindHeaderCol(ws, "rate", "Rate")
colGstPct = FindHeaderCol(ws, "Item Gst %", "GST %", "gst%")
colHSN = FindHeaderCol(ws, "Item HSN Code", "HSN Code", "HSN")
colIRN = FindHeaderCol(ws, "Irn No", "IRN No", "IRN")
colAck = FindHeaderCol(ws, "Acknowledgerment No", "Acknowledgement No", "Ack No")

If colVNo * colDate * colParty * colState * colGSTIN * colItem * colQty * colRate * colGstPct = 0 Then
MsgBox "Missing required headers. Need: Voucher No, date, Party Name, state, gstin, itemname, qty, rate, Item Gst %.", vbCritical
Exit Sub
End If

Dim companyState As String
companyState = GetSettingValue("CompanyState", DEFAULT_COMPANY_STATE)

Dim lastRow As Long, r As Long
lastRow = ws.Cells(ws.rows.Count, colVNo).End(xlUp).row

' --- Create dictionary to group rows by voucher number ---
Dim dictVouchers As Object
Set dictVouchers = CreateObject("Scripting.Dictionary")

Dim vNo As String
Dim colItems As Collection

For r = 2 To lastRow
vNo = Trim$(CStr(ws.Cells(r, colVNo).Value))
If vNo = "" Then GoTo NextRow

If Not dictVouchers.Exists(vNo) Then
Set colItems = New Collection
dictVouchers.Add vNo, colItems
End If
dictVouchers(vNo).Add r
NextRow:
Next r

' --- Generate XML ---
Dim strXML As String
strXML = "<ENVELOPE>"
strXML = strXML & "<HEADER><TALLYREQUEST>Import Data</TALLYREQUEST></HEADER>"
strXML = strXML & "<BODY><IMPORTDATA><REQUESTDESC><REPORTNAME>Vouchers</REPORTNAME></REQUESTDESC><REQUESTDATA>"

Dim key As Variant, rVar As Variant
For Each key In dictVouchers.Keys
Dim rowsColl As Collection
Set rowsColl = dictVouchers(key)

' Calculate totals for voucher
Dim totalTaxable As Double, totalGST As Double
totalTaxable = 0
totalGST = 0
For Each rVar In rowsColl
Dim qty As Double, rate As Double, gstRate As Double
qty = Val(ws.Cells(rVar, colQty).Value)
rate = Val(ws.Cells(rVar, colRate).Value)
gstRate = Val(ws.Cells(rVar, colGstPct).Value)
totalTaxable = totalTaxable + Round(qty * rate, 2)
totalGST = totalGST + Round(qty * rate * gstRate / 100#, 2)
Next rVar

' Voucher info from first row
Dim firstRow As Long
firstRow = rowsColl(1)
Dim vParty As String, vState As String, vGSTIN As String, vDate As Variant
vParty = Trim$(CStr(ws.Cells(firstRow, colParty).Value))
vState = Trim$(CStr(ws.Cells(firstRow, colState).Value))
vGSTIN = Trim$(CStr(ws.Cells(firstRow, colGSTIN).Value))
vDate = ws.Cells(firstRow, colDate).Value

Dim useIGST As Boolean
useIGST = (StrComp(UCase$(vState), UCase$(companyState), vbTextCompare) <> 0)

' Start Voucher
strXML = strXML & "<TALLYMESSAGE xmlns:UDF='TallyUDF'>"
strXML = strXML & "<VOUCHER VCHTYPE='" & XmlEsc(VOUCHER_TYPE) & "' ACTION='Create'>"
strXML = strXML & "<DATE>" & TallyDate(vDate) & "</DATE>"
strXML = strXML & "<VOUCHERTYPENAME>" & XmlEsc(VOUCHER_TYPE) & "</VOUCHERTYPENAME>"
strXML = strXML & "<VOUCHERNUMBER>" & XmlEsc(key) & "</VOUCHERNUMBER>"
strXML = strXML & "<PARTYNAME>" & XmlEsc(vParty) & "</PARTYNAME>"
strXML = strXML & "<PARTYLEDGERNAME>" & XmlEsc(vParty) & "</PARTYLEDGERNAME>"
strXML = strXML & "<PartyGSTIN>" & vGSTIN & "</PartyGSTIN>"
strXML = strXML & "<COUNTRYOfResidence>India</COUNTRYOfResidence>"
strXML = strXML & "<STATENAME>" & vState & "</STATENAME>"
strXML = strXML & "<IsInvoice>Yes</IsInvoice>"
strXML = strXML & "<PLACEOFSUPPLY>" & companyState & "</PLACEOFSUPPLY>"

' Party ledger entry
strXML = strXML & "<LEDGERENTRIES.LIST>"
strXML = strXML & "<LEDGERNAME>" & XmlEsc(vParty) & "</LEDGERNAME>"
strXML = strXML & "<ISDEEMEDPOSITIVE>Yes</ISDEEMEDPOSITIVE>"
strXML = strXML & "<ISPARTYLEDGER>Yes</ISPARTYLEDGER>"
strXML = strXML & "<AMOUNT>" & FmtAmt(-(totalTaxable + totalGST)) & "</AMOUNT>"
strXML = strXML & "</LEDGERENTRIES.LIST>"

' === GST totals dictionary ===
Dim gstTotals As Object
Set gstTotals = CreateObject("Scripting.Dictionary")

' Inventory entries per item
For Each rVar In rowsColl
Dim vItem As String, hsn As String, irn As String, ack As String
Dim taxable As Double, gstAmt As Double, ledSales As String, ledCGST As String, ledSGST As String, ledIGST As String

vItem = Trim$(CStr(ws.Cells(rVar, colItem).Value))
qty = Val(ws.Cells(rVar, colQty).Value)
rate = Val(ws.Cells(rVar, colRate).Value)
gstRate = Val(ws.Cells(rVar, colGstPct).Value)
hsn = IIf(colHSN > 0, Trim$(CStr(ws.Cells(rVar, colHSN).Value)), "")
irn = IIf(colIRN > 0, Trim$(CStr(ws.Cells(rVar, colIRN).Value)), "")
ack = IIf(colAck > 0, Trim$(CStr(ws.Cells(rVar, colAck).Value)), "")

taxable = Round(qty * rate, 2)
gstAmt = Round(taxable * gstRate / 100#, 2)

ledSales = GetLedgerForRate(gstRate, "SALES")
ledCGST = GetLedgerForRate(gstRate, "CGST")
ledSGST = GetLedgerForRate(gstRate, "SGST")
ledIGST = GetLedgerForRate(gstRate, "IGST")

' Inventory entry XML
strXML = strXML & "<INVENTORYENTRIES.LIST>"
strXML = strXML & "<STOCKITEMNAME>" & XmlEsc(vItem) & "</STOCKITEMNAME>"
strXML = strXML & "<ISDEEMEDPOSITIVE>No</ISDEEMEDPOSITIVE>"
strXML = strXML & "<ACTUALQTY>" & FmtAmt(qty) & "</ACTUALQTY>"
strXML = strXML & "<BILLEDQTY>" & FmtAmt(qty) & "</BILLEDQTY>"
strXML = strXML & "<RATE>" & FmtAmt(rate) & "</RATE>"
strXML = strXML & "<AMOUNT>" & FmtAmt(taxable) & "</AMOUNT>"
If Len(hsn) > 0 Then strXML = strXML & "<HSNCODE>" & XmlEsc(hsn) & "</HSNCODE>"

strXML = strXML & "<BATCHALLOCATIONS.LIST>"
strXML = strXML & "<GODOWNNAME>" & XmlEsc(BATCH_GODOWN) & "</GODOWNNAME>"
strXML = strXML & "<DESTINATIONGODOWNNAME>" & XmlEsc(BATCH_GODOWN) & "</DESTINATIONGODOWNNAME>"
strXML = strXML & "<BATCHNAME>" & XmlEsc(BATCH_NAME) & "</BATCHNAME>"
strXML = strXML & "<ISDEEMEDPOSITIVE>No</ISDEEMEDPOSITIVE>"
strXML = strXML & "<AMOUNT>" & FmtAmt(taxable) & "</AMOUNT>"
strXML = strXML & "<ACTUALQTY>" & FmtAmt(qty) & "</ACTUALQTY>"
strXML = strXML & "<BILLEDQTY>" & FmtAmt(qty) & "</BILLEDQTY>"
strXML = strXML & "</BATCHALLOCATIONS.LIST>"

strXML = strXML & "<ACCOUNTINGALLOCATIONS.LIST>"
strXML = strXML & "<LEDGERNAME>" & XmlEsc(ledSales) & "</LEDGERNAME>"
strXML = strXML & "<ISDEEMEDPOSITIVE>No</ISDEEMEDPOSITIVE>"
strXML = strXML & "<AMOUNT>" & FmtAmt(taxable) & "</AMOUNT>"
strXML = strXML & "</ACCOUNTINGALLOCATIONS.LIST>"
strXML = strXML & "</INVENTORYENTRIES.LIST>"

' Collect GST totals instead of writing immediately
If gstAmt <> 0 Then
If useIGST Then
If Len(ledIGST) > 0 Then gstTotals(ledIGST) = gstTotals(ledIGST) + gstAmt
Else
If Len(ledCGST) > 0 Then gstTotals(ledCGST) = gstTotals(ledCGST) + gstAmt / 2#
If Len(ledSGST) > 0 Then gstTotals(ledSGST) = gstTotals(ledSGST) + gstAmt / 2#
End If
End If
Next rVar

' After items, now write one GST ledger entry per ledger
Dim led As Variant
For Each led In gstTotals.Keys
strXML = strXML & "<LEDGERENTRIES.LIST>"
strXML = strXML & "<LEDGERNAME>" & XmlEsc(led) & "</LEDGERNAME>"
strXML = strXML & "<ISDEEMEDPOSITIVE>No</ISDEEMEDPOSITIVE>"
strXML = strXML & "<AMOUNT>" & FmtAmt(gstTotals(led)) & "</AMOUNT>"
strXML = strXML & "</LEDGERENTRIES.LIST>"
Next led

' End voucher
strXML = strXML & "</VOUCHER>"
strXML = strXML & "</TALLYMESSAGE>"
Next key

strXML = strXML & "</REQUESTDATA></IMPORTDATA></BODY></ENVELOPE>"

' --- Write to file ---
Dim fso As Object, f As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.CreateTextFile("D:\TallySales.xml", True)
f.Write strXML
f.Close

'--- Auto Push to Tally ---
Dim http As Object
Dim resp As String
Set http = CreateObject("MSXML2.XMLHTTP")
http.Open "POST", "http://localhost:9000", False
http.setRequestHeader "Content-Type", "application/xml"
http.Send strXML
resp = http.responseText

' MsgBox "XML generated successfully in D:\TallySales.xml", vbInformation
MsgBox "XML Exported to D:\TallySales.xml" & vbCrLf & "Response from Tally: " & resp
End Sub