Option Explicit
Sub GenerateMasterXML()
'
'Working finally solved by Johnnyl 12:10 hrs 14.03.2022
'
Application.ScreenUpdating = False ' Turn ScreenUpdating off
'
Dim DictionaryRow As Long
Dim FormulaNumber As Long
Dim ImportMastersFormulaStartRow As Long, List_of_LedgersColumnA_LastRow As Long
Dim ListOfLedgersFormulaStartRow As Long
Dim ParticularsMergedColumnCorrectionNumber As Long
Dim OriginalHeaderColumnNumber As Long, OriginalHeaderRow As Long, OriginalLastRow As Long
Dim ParticularsFooterLinesToExclude As Long, ParticularsHeaderLinesToExclude As Long
Dim cell As Range
Dim AvoidText As String
Dim ImportMastersFormulaStartAddress As String, MasterDataLedgersStartAddress As String, VlookupStartAddress As String
Dim ImportMastersFormulaStartColumn As String
Dim ListOfLedgersFormulaColumn As String
Dim ListOfLedgersLedgerColumn As String
Dim MastersDataParticularsColumnLetter As String
Dim OriginalLastColumnLetter As String
Dim ParticularsPasteListOfLedgersStartAddress As String
Dim TextToAvoid As String
Dim XML_FileName As String
Dim DataDictionary As Variant
Dim List_of_LedgersFormulasColumnArray As Variant, OriginalParticularsDataArray As Variant
Dim wsImportMasters As Worksheet, wsListOfLedgers As Worksheet
Dim wsMasterData As Worksheet, wsOriginal As Worksheet
'
Set wsImportMasters = Sheets("ImportMasters")
Set wsListOfLedgers = Sheets("List of Ledgers")
Set wsMasterData = Sheets("MasterData")
Set wsOriginal = Sheets("Original")
'
ImportMastersFormulaStartAddress = "A2" ' <--- Adjust this if needed
ImportMastersFormulaStartColumn = "A" ' <--- Adjust this if needed
ImportMastersFormulaStartRow = 2 ' <--- Adjust this if needed
'
'---------------------------------------------------------------------------------------
'
List_of_LedgersColumnA_LastRow = wsListOfLedgers.Range("A" & _
wsListOfLedgers.Rows.Count).End(xlUp).Row ' Get last row used of column A in List of Ledgers sheet
'
'Or /\ /\ Comment out above line and uncomment \/ \/ to hard code the List_of_LedgersColumnA_LastRow
'' List_of_LedgersColumnA_LastRow = 10000 ' <--- Adjust this if needed
'
'---------------------------------------------------------------------------------------
'
ListOfLedgersFormulaColumn = "F" ' <--- Adjust this if needed
ListOfLedgersFormulaStartRow = 6 ' <--- Adjust this if needed
ListOfLedgersLedgerColumn = "E" ' <--- Adjust this if needed
MasterDataLedgersStartAddress = "B2" ' <--- Adjust this if needed
MastersDataParticularsColumnLetter = "B" ' <--- Adjust this if needed
ParticularsFooterLinesToExclude = 3 ' <--- Set this to # of rows to exclude from Bottom of Particulars
ParticularsHeaderLinesToExclude = 1 ' <--- Set this to # of rows to exclude from top of Particulars
ParticularsMergedColumnCorrectionNumber = 1 ' <--- Set this to # of columns to correct for merged cells
ParticularsPasteListOfLedgersStartAddress = "E6" ' <--- Adjust this if needed
TextToAvoid = "Opening Balance, (as per details), Closing Balance" ' <--- Adjust this if needed
VlookupStartAddress = "$A$6" ' <--- Adjust this if needed
XML_FileName = "C:\Users\" & Environ("username") & "\Desktop\Master.xml" ' <--- Adjust this if needed
'
'---------------------------------------------------------------------------------------
'
With wsOriginal
OriginalLastColumnLetter = Split(Cells(1, (.Cells.Find("*", , xlFormulas, , _
xlByColumns, xlPrevious).Column)).Address, "$")(1) ' Get last column letter used in the Original sheet
OriginalLastRow = .Cells.Find("*", , xlFormulas, , xlByRows, _
xlPrevious).Row - ParticularsFooterLinesToExclude ' Get correct last row of data on the Original sheet
'
With .Range("A1:" & OriginalLastColumnLetter & OriginalLastRow) ' Look through the Original sheet for the header row
Set cell = .Find("Particulars", LookIn:=xlValues) ' Find the header called 'Particulars'
'
If Not cell Is Nothing Then ' If 'Particulars' is found then ...
OriginalHeaderRow = cell.Row + ParticularsHeaderLinesToExclude ' Save the row # into OriginalHeaderRow
OriginalHeaderColumnNumber = cell.Column + ParticularsMergedColumnCorrectionNumber ' Save corrected Column # into OriginalHeaderColumnNumber
' ' to correct for the merged B&C columns
End If
End With
'
OriginalParticularsDataArray = .Range(.Cells(OriginalHeaderRow + 1, OriginalHeaderColumnNumber), _
.Cells(OriginalLastRow, OriginalHeaderColumnNumber)) ' Save Data to be pasted into 2D 1 Based OriginalParticularsDataArray
End With
'
'---------------------------------------------------------------------------------------
'
With wsListOfLedgers
.Columns(ListOfLedgersLedgerColumn & ":" & ListOfLedgersFormulaColumn).ClearContents ' Erase ListOfLedgersLedgerColumn &
' ' ListOfLedgersFormulaColumn in List of Ledgers sheet
.Range(ParticularsPasteListOfLedgersStartAddress).Resize(UBound(OriginalParticularsDataArray, 1)) = _
OriginalParticularsDataArray ' Display OriginalParticularsDataArray to List of Ledgers
'
ReDim List_of_LedgersFormulasColumnArray(1 To UBound(OriginalParticularsDataArray, 1)) ' Set # of rows for the List_of_LedgersFormulasColumnArray
'
For FormulaNumber = 1 To UBound(OriginalParticularsDataArray, 1) ' Loop to put formulas into List_of_LedgersFormulasColumnArray
List_of_LedgersFormulasColumnArray(FormulaNumber) = "=VLOOKUP(E" & 5 + FormulaNumber & _
"," & VlookupStartAddress & ":$A$" & List_of_LedgersColumnA_LastRow & ",1,0)" ' Save Formula into List_of_LedgersFormulasColumnArray
Next ' Loop back
'
.Range(ListOfLedgersFormulaColumn & ListOfLedgersFormulaStartRow).Resize(UBound(List_of_LedgersFormulasColumnArray, 1)) = _
List_of_LedgersFormulasColumnArray ' Display List_of_LedgersFormulasColumnArray ...
'
List_of_LedgersFormulasColumnArray = .Range(ListOfLedgersFormulaColumn & _
ListOfLedgersFormulaStartRow & ":" & ListOfLedgersFormulaColumn & _
.Range(ListOfLedgersLedgerColumn & Rows.Count).End(xlUp).Row) ' Load formula column results from
' ' List of Ledgers sheet to array
'
Application.Goto .Range(ParticularsPasteListOfLedgersStartAddress) ' Select ParticularsPasteListOfLedgersStartAddress on List of Ledgers sheet
'
DataDictionary = .Range(ParticularsPasteListOfLedgersStartAddress, _
.Cells(Rows.Count, ListOfLedgersFormulaColumn).End(xlUp)) ' Create DataDictionary
End With
'
'---------------------------------------------------------------------------------------
'
' solved by gravanoc 17:12 hrs 13.03.2022
AvoidText = TextToAvoid ' Text to avoid
'
With CreateObject("Scripting.Dictionary")
For DictionaryRow = 1 To UBound(DataDictionary) ' Loop through each row of DataDictionary
If Not .Exists(DataDictionary(DictionaryRow, 1)) And _
IsError(List_of_LedgersFormulasColumnArray(DictionaryRow, 1)) Then ' If unique value found & ...
' ' Error found in column to the right then ...
If InStr(1, AvoidText, DataDictionary(DictionaryRow, 1)) = 0 Then
.Add DataDictionary(DictionaryRow, 1), Array(DataDictionary(DictionaryRow, 2)) ' add unique value to DataDictionary
End If
End If
Next ' Loop back
'
wsMasterData.Range(MasterDataLedgersStartAddress, _
wsMasterData.Range(MasterDataLedgersStartAddress).End(xlDown)).ClearContents ' Erase column B data in MasterData sheet
'
If .Count > 0 Then ' Handle Error 13 when all match
wsMasterData.Range(MasterDataLedgersStartAddress).Resize(.Count) = _
Application.Transpose(.keys) ' Display unique values on wsMasterData
End If
'
If wsMasterData.Range(MasterDataLedgersStartAddress) = "" Then ' If all ledgers match then ...
MsgBox "All Ledgers available." ' Display message to user
Exit Sub ' Exit sub
End If
End With
'
'---------------------------------------------------------------------------------------
'
Application.Goto wsMasterData.Range("B1") ' Select B1 on MasterData sheet
'
Dim LastColumnNumberInRow As Long
Dim LastRowInSheetImportMasters As Long
Dim LedgerCount As Long
Dim xmlFile As Object
Dim LastColumnLetterSheetImportMasters As String
Dim strData As String
Dim strTempFile As String
'
With wsImportMasters
LastColumnLetterSheetImportMasters = Split(Cells(1, (.Cells.Find("*", , xlFormulas, _
, xlByColumns, xlPrevious).Column)).Address, "$")(1) ' Get last column letter used in ImportMasters sheet
LastRowInSheetImportMasters = .Cells.Find("*", , xlFormulas, , xlByRows, _
xlPrevious).Row ' Get last row used in ImportMasters sheet
'
.Range(ImportMastersFormulaStartColumn & ImportMastersFormulaStartRow + 1 & ":" & _
LastColumnLetterSheetImportMasters & LastRowInSheetImportMasters).ClearContents ' Erase all but one row of formulas on ImportMasters sheet
'
LedgerCount = wsMasterData.Range(MasterDataLedgersStartAddress & ":" & _
MastersDataParticularsColumnLetter & wsMasterData.Range(MastersDataParticularsColumnLetter & _
Rows.Count).End(xlUp).Row).Rows.Count ' Get count of ledgers
'
If LedgerCount > 1 Then .Range(ImportMastersFormulaStartAddress & ":" & _
LastColumnLetterSheetImportMasters & LedgerCount + 1).FillDown ' If LedgerCount > 1 Then Create range of formulas
'
LastColumnNumberInRow = .Cells(ImportMastersFormulaStartRow, _
.Columns.Count).End(xlToLeft).Column ' Get last column # used in row ImportMastersFormulaStartRow
'
.Range(ImportMastersFormulaStartAddress).Resize(LedgerCount, LastColumnNumberInRow).Copy ' Copy ImportMasters Formula results
End With
'
'---------------------------------------------------------------------------------------
'
strData = CreateObject("htmlfile").ParentWindow.ClipboardData.GetData("Text") ' Save contents into strData
strTempFile = XML_FileName ' Set File name to copy to
CreateObject("Scripting.FileSystemObject").CreateTextFile(strTempFile, True).Write strData ' Write the data to file
'
MsgBox ("File saved on Desktop as Master.XML.") ' Display message to user
'
Application.ScreenUpdating = True ' Turn ScreenUpdating back on
End Sub
