Sub MoveDataToDifferentSheetsV3()
'
Application.ScreenUpdating = False ' Turn ScreenUpdating off
'
Dim StartTime As Single
StartTime = Timer ' Start the stop watch
'
Dim DictionaryRow As Long
Dim FormulaNumber As Long
Dim List_of_LedgersColumnA_LastRow As Long, ParticularsLastRow As Long, SourceLastRow As Long
Dim SourceHeaderColumnNumber As Long, SourceHeaderRow As Long
Dim cell As Range
Dim CodeCompletionTime As Single
Dim SourceLastColumnLetter As String
Dim VlookupStartAddress As String
Dim DataDictionary As Variant
Dim FormulaArray As Variant, List_of_LedgersFormulaResultsArray As Variant, PasteDataParticularsDataArray As Variant
Dim SourceWS As Worksheet
'
Set SourceWS = Sheets("PasteData") ' <--- Set this to the source sheet
VlookupStartAddress = "$A$6" ' <--- Set this to the proper start address
'
Sheets("MasterData").Range("B2", Sheets("MasterData").Range("B2").End(xlDown)).ClearContents ' Clear old data from Sheets("MasterData")
Sheets("List of Ledgers").Columns("E:F").ClearContents ' Clear old data from Sheets("List of Ledgers")
'
With SourceWS
SourceLastColumnLetter = Split(Cells(1, (.Cells.Find("*", , xlFormulas, , _
xlByColumns, xlPrevious).Column)).Address, "$")(1) ' Get last column letter used in the source sheet
SourceLastRow = .Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row - 1 ' Get the last source row of data minus the total row
'
With .Range("A1:" & SourceLastColumnLetter & SourceLastRow) ' Look through the source 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 ...
SourceHeaderRow = cell.Row ' Save the row # into SourceHeaderRow
SourceHeaderColumnNumber = cell.Column ' Save the Column # into SourceHeaderColumn
End If
End With
'
ParticularsLastRow = .Cells(SourceHeaderRow + 1, SourceHeaderColumnNumber).End(xlDown).Row ' Get last Row of consecutive data in 'Particulars' column
If ParticularsLastRow = SourceLastRow Then ParticularsLastRow = ParticularsLastRow - 1 ' If no blanks found in column before the total line then subtract 1
'
PasteDataParticularsDataArray = .Range(.Cells(SourceHeaderRow + 1, SourceHeaderColumnNumber), _
.Cells(ParticularsLastRow, SourceHeaderColumnNumber)) ' Save Data to be pasted into 2D 1 Based PasteDataParticularsDataArray
End With
'
With Sheets("List of Ledgers")
List_of_LedgersColumnA_LastRow = .Range("A" & Rows.Count).End(xlUp).Row ' Get last row used in Sheets("List of Ledgers") column A
'
.Range("E6").Resize(UBound(PasteDataParticularsDataArray, 1)) = PasteDataParticularsDataArray 'Display PasteDataParticularsDataArray to Sheets("List of Ledgers")
'
ReDim FormulaArray(1 To UBound(PasteDataParticularsDataArray, 1)) ' Set the number of rows for the FormulaArray
'
For FormulaNumber = 1 To UBound(PasteDataParticularsDataArray, 1) ' Loop to put formulas into FormulaArray
FormulaArray(FormulaNumber) = "=VLOOKUP(E" & 5 + FormulaNumber & "," & _
VlookupStartAddress & ":$A$" & List_of_LedgersColumnA_LastRow & ",1,0)" ' Save Formula into FormulaArray
Next ' Loop back
'
.Range("F6").Resize(UBound(FormulaArray, 1)) = FormulaArray 'Display FormulaArray to Sheets("List of Ledgers")
'
List_of_LedgersFormulaResultsArray = .Range("F6:F" & Range("F6").End(xlDown).Row) ' Load formula column Results from Sheets("List of Ledgers") to array
'
DataDictionary = .Range("E6", .Cells(Rows.Count, "F").End(xlUp)) ' Create DataDictionary
End With
'
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_LedgersFormulaResultsArray(DictionaryRow, 1)) Then ' If uniue value found & ...
' ' Error found in column to the right then ...
.Add DataDictionary(DictionaryRow, 1), Array(DataDictionary(DictionaryRow, 2)) ' add unique value to DataDictionary
End If
Next ' Loop back
'
If .Count > 0 Then ' If dictionary count > 0 then ...
Sheets("MasterData").Range("B2").Resize(.Count) = Application.Transpose(.keys) ' Display unique values on Sheets("MasterData")
Else
CodeCompletionTime = Timer - StartTime ' Stop the stop watch
MsgBox "All Ledgers Available." ' Display message to user
GoTo Continue ' Jump to Continue:
End If
End With
'
CodeCompletionTime = Timer - StartTime ' Stop the stop watch
'
Continue:
Application.ScreenUpdating = True ' Turn ScreenUpdating back on
'
CodeCompletionTime = Format(CodeCompletionTime, ".#####") ' Prevent scientific notation results
Debug.Print "Time to complete MoveDataToDifferentSheets = " & CodeCompletionTime & " seconds." ' Display the time elapsed to the user (Ctrl-G)
'
Application.Speech.Speak "This code completed in, , , " & CodeCompletionTime & " seconds." ' Provide audio result
End Sub
