I am using with two different data dumps which are saved in OPL_Dump and OPL_DUMP_2 sheets.
The code i am trying to improve (shared below), finds the data in one of the dumps' and copies and pastes as a new parameter as addition to the same corresponding value it sees for the other dump.
The length of both the data dumps varies on a daily basis and i am trying to make my code a bit more robust instead of manually amending the length of the range every time.
For this, i defined N and L instead of fixed numbers' of last rows but it it is not working.
Can someone help please ?
Sub Merging_Both_Dumps_for_Product_Type()
Dim out() As String
'Dim out2() As String
L As Long
L = ThisWorkbook.Sheets("OPL_DUMP_2").Select.Cells(Rows.Count, "B").End(xlUp).Row
ThisWorkbook.Sheets("OPL_DUMP_2").Select
keyarray = Range("F" & 2 & ":F" & L)
valuearray = Range("J" & 2 & ":J" & L)
N As Long
N = ThisWorkbook.Sheets("OPL_DUMP").Select.Cells(Rows.Count, "B").End(xlUp).Row
ReDim out(N, 0)
For j = 2 To N
ind = Index(keyarray, ThisWorkbook.Sheets("OPL_DUMP").Cells(j, 2).Value)
out(j - 2, 0) = valuearray(ind, 1)
Next j
'ReDim out2(1, 0)
'out2(1, 0) = "test"
'ThisWorkbook.Sheets("OPL_DUMP").Range("AD2:AD3") = out2()
ThisWorkbook.Sheets("OPL_DUMP").Range("AC" & 2 & ":AC" & N) = out
End Sub
CodePudding user response：
Try this code, should work fine, fast and always no matter the size of your dumps:
Option Explicit
Sub Merging_Both_Dumps_for_Product_Type()
'You need the reference Microsoft Scripting Runtime
'under tools-references activated for this code to work.
Dim output_values As Dictionary
Set output_values = load_output_values(ThisWorkbook.Sheets("OPL_DUMP_2").UsedRange.Value)
'Store your output worksheet inside an array
Dim arr As Variant: arr = ThisWorkbook.Sheets("OPL_DUMP").UsedRange.Value
'loop through the array
Dim i As Long
For i = 2 To UBound(arr)
'check if the value in col B exists in the dictionary
If output_values.Exists(arr(i, 2)) Then
arr(i, 29) = output_values(arr(i, 2))
End If
Next i
'paste back the array to the worksheet
ThisWorkbook.Sheets("OPL_DUMP").UsedRange.Value = arr
'Note that using worksheet.usedrange.value will store
'everything in the sheet that has been used, even if its blank
'meaning if you do ctrl end in your keyboard, the array will be
'as big as A1: the cell where ctrl end sends you.
End Sub
Private Function load_output_values(arr As Variant) As Dictionary
'this function will store in a dictionary each key (col F = index 2)
'with it's item (col J = index 10)
'Since we stored the sheet inside an array we can loop through it
Set load_output_values = New Dictionary ' init the dictionary
Dim i As Long
For i = 2 To UBound(arr)
'first check either column B is empty or already exists
'will take the first ocurrence if col B is duplicated.
If Not arr(i, 2) = vbNullString _
And Not load_output_values.Exists(arr(i, 2)) Then
load_output_values.Add arr(i, 2), arr(i, 10)
End If
Next i
End Function
CodePudding user response：
Lookup Data Using Application.Match
Option Explicit
Sub LookupData()
' 1. Define constants.
' Source
Const sName As String = "OPL_DUMP_2"
Const skCol As String = "F" ' 2. ... lookup the key...
Const svCol As String = "J" ' 3. ... read the associated value...
Const sfRow As Long = 2
' Destination
Const dName As String = "OPL_DUMP"
Const dkCol As String = "B" ' 1. Read the key...
Const dvCol As String = "AC" ' 4. ... write the value.
Const dfRow As Long = 2
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' 2. Reference the source key (one-column) range ('skrg')
' and write the values from the source value (one-column) range ('svrg')
' to a 2D one-based (one-column) array ('svData').
' We will use 'skrg' because 'Application.Match' is faster on a range.
' We will use 'svData' because reading from an array is faster than
' from a range.
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, skCol).End(xlUp).Row
Dim srCount As Long: srCount = slRow - sfRow 1
If srCount < 1 Then
MsgBox "No data in column range.", vbCritical
Exit Sub
End If
Dim skrg As Range: Set skrg = sws.Cells(sfRow, skCol).Resize(srCount)
' ... which is the same as:
'Set skrg = sws.Range(sws.Cells(sfRow, skCol), sws.Cells(slrow, skCol))
Dim svrg As Range: Set svrg = skrg.EntireRow.Columns(svCol)
Dim svData() As Variant
If srCount = 1 Then ' one cell
ReDim svData(1 To 1, 1 To 1): svData(1, 1) = svrg.Value
Else ' multiple cells
svData = svrg.Value
End If
' 3. Reference the destination key (one-column) range ('skrg')
' and write its values the to a 2D one-based (one-column) array,
' the destination keys array ('dkData').
' We will use 'dkData' because reading from an array is faster than
' from a range.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dlRow As Long: dlRow = dws.Cells(dws.Rows.Count, dkCol).End(xlUp).Row
Dim drCount As Long: drCount = dlRow - dfRow 1
If drCount < 1 Then
MsgBox "No data in column range.", vbCritical
Exit Sub
End If
Dim dkrg As Range: Set dkrg = dws.Cells(dfRow, dkCol).Resize(drCount)
' ... which is the same as:
'Set dkrg = dws.Range(dws.Cells(dfRow, dkCol), dws.Cells(dlrow, dkCol))
Dim dkData() As Variant
If drCount = 1 Then ' one cell
ReDim dkData(1 To 1, 1 To 1): dkData(1, 1) = dkrg.Value
Else ' multiple cells
dkData = dkrg.Value
End If
' 3. Write the matching values to the destination values array ('dvData'),
' a 2D one-based one-column array, with the same number of rows
' as the number of rows of the destination keys array.
Dim dvData() As Variant: ReDim dvData(1 To drCount, 1 To 1)
Dim sr As Variant
Dim dValue As Variant
Dim dr As Long
For dr = 1 To drCount
dValue = dkData(dr, 1)
sr = Application.Match(dValue, skrg, 0)
If IsNumeric(sr) Then ' is a number (the row index)
dvData(dr, 1) = svData(sr, 1)
'Else ' is an error value (no match); do nothing
End If
Next dr
' 4. Write the values from the destination values array
' to the destination values range ('dvrg').
Dim dvrg As Range: Set dvrg = dkrg.EntireRow.Columns(dvCol)
dvrg.Value = dvData
' Save the workbook.
'wb.Save
' 5. Inform.
MsgBox "Lookup has finished.", vbInformation
End Sub