Option Explicit
Dim LedgerCount As Long
Dim R
Sub GenerateMasterXML()
'
Dim LastColumnNumberInRow As Long
Dim LastColumnLetterSheetImportMasters As String
'
Application.ScreenUpdating = False
'
'--------------------------------------------------------------------------------------------------
'
Call Pre_XML_Code ' Perform preliminary actions
Call ClearCommonDataFromSheet(Sheets("ImportMasters")) ' Clear extra data from ImportMasters
'
If Sheets("MasterData").Range("B2") = vbNullString Then ' If B2 in MasterData is blank then ...
MsgBox "All Ledgers Available. Press Generate Purchase.XML" ' Display message to user
Exit Sub ' Exit the code
End If
'
LedgerCount = Sheets("MasterData").Range("B2:B" & Sheets("MasterData").Range("B" & _
Rows.Count).End(xlUp).Row).Rows.Count ' Get count of rows to write to file
'
With Sheets("ImportMasters")
LastColumnNumberInRow = .Cells(2, .Columns.Count).End(xlToLeft).Column ' Get last column number in row
'
LastColumnLetterSheetImportMasters = Split(Cells(1, (.Cells.Find("*", , xlFormulas, _
, xlByColumns, xlPrevious).Column)).Address, "$")(1) ' Get last column letter used in Sheets("ImportMasters")
'
If LedgerCount > 1 Then .Range("A2:" & LastColumnLetterSheetImportMasters & _
LedgerCount + 1).FillDown ' If LedgerCount > 1 Then Create range needed to copy
'
.Range("A2").Resize(LedgerCount, LastColumnNumberInRow).Copy '
'
.UsedRange.EntireColumn.AutoFit ' Set all used columns on sheet wide enough for data
End With
'
Call GenerateXML("Master.xml")
'
MsgBox ("File saved on Desktop as Master.XML.")
End Sub
Sub GeneratePurchaseXML()
'
Dim LastColumnNumberInRowImportPurchase As Long
Dim LastColumnNumberInRowPurchaseData As Long
Dim LastColumnLetterSheetImportPurchase As String
Dim LastColumnLetterSheetPurchaseData As String
'
Application.ScreenUpdating = False
'
'--------------------------------------------------------------------------------------------------
'
Call Pre_XML_Code ' Perform preliminary actions
'
If Sheets("PurchaseData").Range("A2") = "" Then
MsgBox "Data Not Found"
Exit Sub
End If
'
R = Sheets("CopyData").Range("A2:A" & Sheets("CopyData").Range("A" & _
Rows.Count).End(xlUp).Row).Rows.Count ' Get count of rows to write to file
'
With Sheets("PurchaseData")
LastColumnNumberInRowPurchaseData = .Cells(2, .Columns.Count).End(xlToLeft).Column ' Get last column number in row
LastColumnLetterSheetPurchaseData = Split(Cells(1, (.Cells.Find("*", _
, xlFormulas, , xlByColumns, xlPrevious).Column)).Address, "$")(1) ' Get last column letter used in Sheets("PurchaseData")
'
.Range("A2:" & LastColumnLetterSheetPurchaseData & R + 1).FillDown ' Create range needed to copy
LedgerCount = .Range("B2:B" & .Range("B" & Rows.Count).End(xlUp).Row).Rows.Count ' Get count of rows to write to file
'
.UsedRange.EntireColumn.AutoFit ' Set all used columns on sheet wide enough for data
End With
'
With Sheets("ImportPurchase")
LastColumnNumberInRowImportPurchase = .Cells(2, .Columns.Count).End(xlToLeft).Column ' Get last column number in row
LastColumnLetterSheetImportPurchase = Split(Cells(1, (.Cells.Find("*", _
, xlFormulas, , xlByColumns, xlPrevious).Column)).Address, "$")(1) ' Get last column letter used in Sheets("ImportPurchase")
'
If LedgerCount > 1 Then .Range("A2:" & LastColumnLetterSheetImportPurchase & LedgerCount + 1).FillDown ' If LedgerCount > 1 Then Create range needed to copy
.Range("A2").Resize(LedgerCount, LastColumnNumberInRowImportPurchase).Copy
'
.UsedRange.EntireColumn.AutoFit ' Set all used columns on sheet wide enough for data
End With
'
Call GenerateXML("Purchase.xml")
'
MsgBox ("File saved on Desktop as Purchase.XML. Copy path and paste in tally.")
End Sub
Sub Pre_XML_Code()
'
Dim c, a, l&
Dim Data, Ledger, Chk, i As Long
Dim J, k, n, ar, nChar, xstr
Dim t() As String
Dim arr()
Dim ws1 As Worksheet
'
'
'--------------------------------------------------------------------------------------------------
'
' ClearOldWorkings
With Sheets("CopyData")
.Range("A2:AB2", .Range("A2:AB2").End(xlDown)).ClearContents
.Range("AC3:AU3", .Range("AC3:AU3").End(xlDown)).ClearContents
End With
'
'--------------------------------------------------------------------------------------------------
'
With Sheets("MasterData")
.Range("B2:E2", .Range("B2:E2").End(xlDown)).ClearContents
.Range("F2:I10", .Range("F2:I10").End(xlDown)).ClearContents
End With
'
'--------------------------------------------------------------------------------------------------
'
' Clear common data from the following sheets
Call ClearCommonDataFromSheet(Sheets("PurchaseData"))
Call ClearCommonDataFromSheet(Sheets("ImportPurchase"))
'--------------------------------------------------------------------------------------------------
'
' Move_PasteData_to_CopyData
With Sheets("PasteData")
l = .Cells(Rows.Count, 1).End(xlUp).Row
c = .Evaluate("iferror(MATCH(CopyData!A1:Z1,A1:zz1,),99)")
R = .Evaluate("ROW(A2:A" & l & ")")
a = Application.Index(.[a:zz], R, c)
'
If l > 2 Then ' If more than 1 row of data then ...
Sheets("CopyData").[A2:Z2].Resize(UBound(a)) = a 'if additional expense columns added then change range Z2
Else
Sheets("CopyData").Range("A2:Z2") = a 'if additional expense columns added then change range Z2
End If
End With
'
If l > 2 Then ' If more than 1 row of data then ...
Sheets("CopyData").Range("AC2:AU" & Sheets("CopyData").Cells(Rows.Count, 1).End(xlUp).Row).FillDown ' Copy the AC2:AU2 formulas down to last row of A
End If
'
'--------------------------------------------------------------------------------------------------
'
' Get_NA_Ledgers
With Sheets("CopyData")
Data = .Range("N2:N" & .Cells(.Rows.Count, 14).End(xlUp).Row).Value
End With
'
With Sheets("List of Ledgers")
Ledger = .Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row).Value
End With
'
With CreateObject("Scripting.Dictionary")
If IsArray(Data) Then ' Check to see if 'Data' is an array
For i = 1 To UBound(Data) ' If it is an array then loop through it
Chk = Application.Match(Data(i, 1), Application.Index(Ledger, , 1), 0)
If IsError(Chk) And Not .Exists(Data(i, 1)) Then .Add Data(i, 1), ""
Next i
Else ' If it is not an array then there was only 1 item to save
Chk = Application.Match(Data, Application.Index(Ledger, , 1), 0) ' Handle Data as a normal variable
If IsError(Chk) And Not .Exists(Data) Then .Add Data, ""
End If
'
If .Count > 0 Then ' If dictionary count > 0 then ...
Sheets("MasterData").Range("B2").Resize(.Count) = Application.Transpose(.keys)
LedgerCount = .Count ' Save the LedgerCount
Else
'MsgBox "All Ledgers Available." ' Display message to user
End If
End With
'
'If Range("B2").Value = "" Then Exit Sub 'add this line to avoid copying the headings when no data in B2 still error
With Sheets("MasterData")
.Range("C:E").NumberFormat = "General" ' Set columns to General format
'
.Range("C2").Formula = "=IFERROR(IF(B2="""","""",VLOOKUP(B2,CopyData!$N$2" & _
":$O$" & Sheets("CopyData").Cells(Rows.Count, 1).End(xlUp).Row & ",2,0)),"""")" ' Write updated formula to C2
.Range("D2").Formula = "=IFERROR(VLOOKUP(LEFT($C2,2)+0,'States Code'!$A$1:$B$37,2,0),"""")" ' Write formula to D2
.Range("E2").Formula = "=IFERROR(VLOOKUP(B2,CopyData!$N$2:$P$" & _
Sheets("CopyData").Cells(Rows.Count, 1).End(xlUp).Row & ",3,0),"""")" ' Write updated formula to E2
'
If .Range("B2").Value = "" Then Exit Sub ' this line I tried but still didn't work, works now with '.Range'
If LedgerCount > 1 Then .Range("C2:E" & .Cells(Rows.Count, 2).End(xlUp).Row).FillDown ' Copy the C2:E2 formulas down to last row of B
End With
'
'--------------------------------------------------------------------------------------------------
'
' Split_Address
'
Set ws1 = Worksheets("MasterData")
'
With ws1
ar = .[A1].CurrentRegion 'row number..?
End With
'
ReDim Preserve arr(1 To UBound(ar, 1), 1 To 6)
'
k = 1
nChar = 30 'Restricts the number of characters in a cell up to total 120 characters, can edit if required in future
'
For i = 2 To UBound(ar, 1)
If ar(i, 5) = "" Then GoTo nexti ' 5 is the full address in column E
t = Split(ar(i, 5), ",")
xstr = t(0)
n = 1
nChar = 20
'
For J = 1 To UBound(t)
t(J) = Trim(t(J))
'
If t(J) <> "" Then
If Len(xstr & t(J)) <= nChar Then
xstr = xstr & " " & t(J)
Else
' ReDim Preserve arr(1 To 4, 1 To n)
arr(k, n) = Trim(xstr)
xstr = t(J)
n = n + 1
'
If n = 4 Then nChar = 100
End If
End If
Next J
'
If arr(k, n) = "" Then arr(k, n) = Trim(xstr) 'removes special characters and trims to fit 30 characters in each column
nexti:
k = k + 1
Next i
'
ws1.[F2].Resize(UBound(arr, 1), 6) = arr 'destination first cell where data is split
'
ws1.UsedRange.EntireColumn.AutoFit ' Set all used columns on sheet wide enough for data
End Sub
Sub ClearCommonDataFromSheet(CommonSheet As Worksheet)
'
Dim LastRowInCommonSheet As Long
Dim LastColumnLetterCommonSheet As String
'
With CommonSheet
LastColumnLetterCommonSheet = Split(Cells(1, (.Cells.Find("*", _
, xlFormulas, , xlByColumns, xlPrevious).Column)).Address, "$")(1) ' Get last column letter used in CommonSheet
LastRowInCommonSheet = .Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row ' Find last row # used in CommonSheet
.Range("A3:" & LastColumnLetterCommonSheet & LastRowInCommonSheet + 1).ClearContents ' Clear contents of cells in CommonSheet
End With
End Sub
Sub GenerateXML(XML_FileName As String)
'
Dim strData As String
Dim strTempFile As String
'
strData = CreateObject("htmlfile").ParentWindow.ClipboardData.GetData("Text") ' Save contents into strData
strTempFile = "C:\Users\" & Environ("username") & "\Desktop\" & XML_FileName
CreateObject("Scripting.FileSystemObject").CreateTextFile(strTempFile, True).Write strData ' Write the data to file
'
'--------------------------------------------------------------------------------------------------
'
' Wrap Up
Application.CutCopyMode = False ' Clear clipboard and 'marching ants'
Application.Goto Sheets("List of Ledgers").Range("A1") ' Return to 'List of Ledgers' sheet cell A1
Application.ScreenUpdating = True ' Turn ScreenUpdating back on
End Sub
