Update a blank column using a value in another column.
Sub Apply_FormulaValue()
Dim Ws1 As Long, iRe1 As Long, iCe1 As Long, iLoop As Long, R1 As Long
Dim Ws1MatchCol As Long, Ws1DumpCol As Long
Dim sWs1Val As String
Dim aData() As Variant, aCopy() As Variant, aDump2() As Variant, aDump() As Variant
Erase aData: Erase aDump
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
Ws1 = ActiveSheet.Index
iRe1 = Range(GetLastCell(Ws1)).Row
iCe1 = Range(GetLastCell(Ws1)).Column
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
'Set Column Locations:
'===================================================================================================
Worksheets(Ws1).Select
Ws1MatchCol = Application.InputBox(Prompt:="What Column contains the [Source Data]?", Title:="Specify Column by Clicking on ANY Cell within that Column", Default:=Cells(2, 1).Address, Type:=8).Column
Ws1DumpCol = Application.InputBox(Prompt:="What Column will update [Converted Value]?", Title:="Specify Column by Clicking on ANY Cell within that Column", Default:=Cells(2, iCe1 + 1).Address, Type:=8).Column
If Ws1MatchCol = 0 Or Ws1DumpCol = 0 Then GoTo HeaderNotSetAbandonAllHope
'===================================================================================================
'===================================================================================================
Worksheets(Ws1).Select
aData = Range(Worksheets(Ws1).Cells(1, Ws1MatchCol).Address, Worksheets(Ws1).Cells(iRe1, Ws1MatchCol).Address)
aDump = Range(Worksheets(Ws1).Cells(1, Ws1DumpCol).Address, Worksheets(Ws1).Cells(iRe1, Ws1DumpCol).Address)
'===================================================================================================
'===================================================================================================
'Clean up any residual data (In case of multiple matching attemps)
For iLoop = LBound(aDump) + 1 To UBound(aDump)
aDump(iLoop, 1) = ""
Next iLoop
'===================================================================================================
'===================================================================================================
For R1 = LBound(aData) + 1 To UBound(aData)
DoEvents
If Right(R1, 2) = "00" Then Application.StatusBar = R1 & " of " & UBound(aData)
'Use ANY Custom UDF here
sWs1Val = udfCustomFunction(aData(R1, 1))
'Load the array
aDump(R1, 1) = sWs1Val
'Clear the array value if it is set to "0" (Optional)
If aDump(R1, 1) = 0 Then aDump(R1, 1) = ""
Next R1
'===================================================================================================
'===================================================================================================
'Add Headers to Updated Data:
aDump(1, 1) = "HeaderValue"
'===================================================================================================
'===================================================================================================
Worksheets(Ws1).Select
Set Destination = Range(Worksheets(Ws1).Cells(1, Ws1DumpCol).Address)
Destination.Resize(UBound(aDump, 1), UBound(aDump, 2)).Value = aDump
'===================================================================================================
'EEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE
GoTo EraseMemoryPlease
Exit Sub
'EEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE
HeaderNotSetAbandonAllHope:
Debug.Print "Check for missing header"
GoTo EraseMemoryPlease
Exit Sub
'EEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
EraseMemoryPlease:
Erase aData: Erase aDump
Application.StatusBar = ""
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
End Sub
Dim Ws1 As Long, iRe1 As Long, iCe1 As Long, iLoop As Long, R1 As Long
Dim Ws1MatchCol As Long, Ws1DumpCol As Long
Dim sWs1Val As String
Dim aData() As Variant, aCopy() As Variant, aDump2() As Variant, aDump() As Variant
Erase aData: Erase aDump
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
Ws1 = ActiveSheet.Index
iRe1 = Range(GetLastCell(Ws1)).Row
iCe1 = Range(GetLastCell(Ws1)).Column
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
'Set Column Locations:
'===================================================================================================
Worksheets(Ws1).Select
Ws1MatchCol = Application.InputBox(Prompt:="What Column contains the [Source Data]?", Title:="Specify Column by Clicking on ANY Cell within that Column", Default:=Cells(2, 1).Address, Type:=8).Column
Ws1DumpCol = Application.InputBox(Prompt:="What Column will update [Converted Value]?", Title:="Specify Column by Clicking on ANY Cell within that Column", Default:=Cells(2, iCe1 + 1).Address, Type:=8).Column
If Ws1MatchCol = 0 Or Ws1DumpCol = 0 Then GoTo HeaderNotSetAbandonAllHope
'===================================================================================================
'===================================================================================================
Worksheets(Ws1).Select
aData = Range(Worksheets(Ws1).Cells(1, Ws1MatchCol).Address, Worksheets(Ws1).Cells(iRe1, Ws1MatchCol).Address)
aDump = Range(Worksheets(Ws1).Cells(1, Ws1DumpCol).Address, Worksheets(Ws1).Cells(iRe1, Ws1DumpCol).Address)
'===================================================================================================
'===================================================================================================
'Clean up any residual data (In case of multiple matching attemps)
For iLoop = LBound(aDump) + 1 To UBound(aDump)
aDump(iLoop, 1) = ""
Next iLoop
'===================================================================================================
'===================================================================================================
For R1 = LBound(aData) + 1 To UBound(aData)
DoEvents
If Right(R1, 2) = "00" Then Application.StatusBar = R1 & " of " & UBound(aData)
'Use ANY Custom UDF here
sWs1Val = udfCustomFunction(aData(R1, 1))
'Load the array
aDump(R1, 1) = sWs1Val
'Clear the array value if it is set to "0" (Optional)
If aDump(R1, 1) = 0 Then aDump(R1, 1) = ""
Next R1
'===================================================================================================
'===================================================================================================
'Add Headers to Updated Data:
aDump(1, 1) = "HeaderValue"
'===================================================================================================
'===================================================================================================
Worksheets(Ws1).Select
Set Destination = Range(Worksheets(Ws1).Cells(1, Ws1DumpCol).Address)
Destination.Resize(UBound(aDump, 1), UBound(aDump, 2)).Value = aDump
'===================================================================================================
'EEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE
GoTo EraseMemoryPlease
Exit Sub
'EEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE
HeaderNotSetAbandonAllHope:
Debug.Print "Check for missing header"
GoTo EraseMemoryPlease
Exit Sub
'EEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
EraseMemoryPlease:
Erase aData: Erase aDump
Application.StatusBar = ""
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
End Sub