RAJESH1960
Banned for repeated rules violations
- Joined
- Mar 26, 2020
- Messages
- 2,313
- Office Version
- 2019
- Platform
- Windows
Hello guys,
At present, In MasterData sheet I am using formulas in cells C2 and D2 dragged till more than 100 rows. I want to resize cells C2 and D2 with B2. So that I don’t have to drag the formula to 100 or more rows every time I use a new data. I want to add this extra line of code but where, I am confused. Or maybe you would want to write your own code.
At present, In MasterData sheet I am using formulas in cells C2 and D2 dragged till more than 100 rows. I want to resize cells C2 and D2 with B2. So that I don’t have to drag the formula to 100 or more rows every time I use a new data. I want to add this extra line of code but where, I am confused. Or maybe you would want to write your own code.
Rich (BB code):
Option Explicit
Sub MoveDataToDifferentSheetsV3a()
'new edited code of JohnnyL
Application.ScreenUpdating = False ' Turn ScreenUpdating off
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 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 + 1 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 & ...
.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
MsgBox "All Ledgers Available." ' Display message to user
GoTo Continue ' Jump to Continue:
End If
End With
Continue:
Application.ScreenUpdating = True ' Turn ScreenUpdating back on
MsgBox "Press Generate Master XML."
End Sub
