VBA copy UsedRange of a column based on column header name - excel

I am trying to copy data from one worksheet to another based on the column-name. In the source worksheet, the data starts at A1. In the destination worksheet, the data should be pasted at row A11 and not A1. If I used EntireColumn.Copy I get an error about the source and destination copy area not being the same. I came across the UsedRange property but I am unbale to apply it to my scenario
For Each columnName In allColumns
'call a function to get the column to copy
If columnToCopy > 0 Then
columnName.Offset(1, 0).EntireColumn.Copy Destination:=ws2.Cells(11, columnToCopy)
End If
Next
In the above snippet, In dont want to use 'EntireColumn'. I only want the columns that have data. The variable columnName is for example 'Person ID'
What is the best way to do this?
Thanks.

This would be a typical approach:
For Each ColumnName In allColumns
If columnToCopy > 0 Then
With ColumnName.Parent
.Range(ColumnName.Offset(1, 0), .Cells(.Rows.Count, ColumnName.Column).End(xlUp)).Copy _
Destination:=ws2.Cells(11, columnToCopy)
End With
End If
Next
Assumes allColumns is a collection of single-cell ranges/column headers.

Copy/Paste Column
There is not enough information to give an accurate answer so here is a scenario you might consider studying.
The Code
Option Explicit
Sub TESTdetermineColumnNumber()
' Define constants. Should be more.
' Define Criteria.
Const Criteria As String = "Total"
' Define Header Row.
Const hRow As Long = 1
' Define Copy Range (Column Range)
' Define Source Worksheet.
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
' Define Header Row Range.
Dim RowRange As Range
Set RowRange = ws.Rows(hRow)
' Determine Column Number.
Dim ColumnNumber As Long
ColumnNumber = determineColumnNumber(RowRange, Criteria)
' Validate Column Number.
If ColumnNumber = 0 Then
Exit Sub
End If
' Determine Last Row.
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, ColumnNumber).End(xlUp).Row
' Define First Data Row Number.
Dim FirstRow As Long
FirstRow = hRow + 1
' Define Column Range.
Dim ColumnRange As Range
Set ColumnRange = ws.Cells(FirstRow, ColumnNumber) _
.Resize(LastRow - FirstRow + 1)
' Define Paste Range.
' Define Destination Worksheet.
Dim ws2 As Worksheet
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
' Define Destination Column.
Dim columnToCopy As Long
columnToCopy = 2
' Define Paste Range.
Dim PasteRange As Range
Set PasteRange = ws2.Cells(11, columnToCopy)
' Copy/Paste.
' Copy values, formulas and formats.
ColumnRange.Copy Destination:=PasteRange
' It is more efficient if you need only values to use the following:
PasteRange.Resize(ColumnRange.Rows.Count).Value = ColumnRange.Value
End Sub
Function determineColumnNumber(RowRange As Range, _
Criteria As String) _
As Long
Dim Temp As Variant
Temp = Application.Match(Criteria, RowRange, 0)
If Not IsError(Temp) Then
determineColumnNumber = Temp
End If
End Function

Related

Replace Existing Values on one Tab With Values From a Table on Another tab

I am trying to find a way to replace all values on the second tab of an Excel workbook with values from a table in a different tab 1 cell to the right of the corresponding value. On Sheet1 there are 2 columns. 1 is called ID and the second is called New ID. On Sheet2 there is a column called ID. I am looking for a way so that when I run a macro the values on Sheet2 will be replaced by the corresponding New ID from Sheet1. For example, on Sheet2 the first ID is ABC. On Sheet1 the corresponding New ID value for ABC is 123. I'd like the VBA script to replace all ABCs on Sheet2 with 123. I need this for varying amounts of data.
Sheet1
Sheet2
So far I've tried the following but it won't change the cells
Sub Test1()
Dim N As Long, L As Long
Dim rLook As Range
Sheets("Sheet1").Select
N = Cells(Rows.Count, "A").End(xlUp).Row
aryA = Range("A2:A" & N)
aryB = Range("B2:B" & N)
Sheets("Sheet2").Select
Set rLook = Range("A2:A" & N)
For L = 1 To N
rLook.Replace aryA(L, 1), aryB(L, 1)
Next L
End Sub
When I run the macro it only changes the same number of rows as Sheet1 so I am left with the following:
Result
After I run this I get an error that says subscript is out of range.
Your error is basically that you reuse N, which is the number of rows from sheet1 to define the range on sheet2.
So my advise is to use more explicit names for variables that explain what the variable "contains".
Furthermore if you don't use the implicit Cells(xxx) but the explicit one Thisworkbook.Worksheets("Sheet1") you can omit the selection of the sheets (and by that reduce the possibility for errors referencing the wrong range).
Plus: you can read both columns of sheet1 into one array
Option Explicit
Public Sub updateSheet2IDs()
Dim wsSource As Worksheet
Set wsSource = ThisWorkbook.Worksheets("Sheet1")
Dim wsTarget As Worksheet
Set wsTarget = ThisWorkbook.Worksheets("Sheet2")
Dim cntRowsSheet1 As Long
Dim arrSource As Variant
With wsSource
cntRowsSheet1 = .Cells(.Rows.Count, "A").End(xlUp).Row
'array includes both columns: arrsource(1,1) = A2, arrsource(1,2) = B2
arrSource = .Range("A2:B" & cntRowsSheet1)
End With
Dim cntRowsSheet2 As Long, rgTarget As Range
With wsTarget
cntRowsSheet2 = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rgTarget = .Range("A2:A" & cntRowsSheet2)
Dim i As Long
For i = 1 To UBound(arrSource, 1) 'ubound gives you the upper bound of the array
rgTarget.Replace arrSource(i, 1), arrSource(i, 2)
Next
End With
End Sub
You could omit the whole "cntRows"-stuff by using currentregion - which returns the area around one cell that is surrounded by empty rows and columns (see https://learn.microsoft.com/en-us/office/vba/api/excel.range.currentregion).
That means that wsSource.Range("A1").CurrentRegionwill return all cells until the first empty row and until the first empty column - I assume this is exactly what your are looking for. The same for sheet2 as well.
To omit the first row, you can use offset:
set rgTarget = wsTarget.Range("A1").CurrentRegion.Offset(1)
The code then looks like
Option Explicit
Public Sub updateSheet2IDs()
Dim wsSource As Worksheet
Set wsSource = ThisWorkbook.Worksheets("Sheet1")
Dim wsTarget As Worksheet
Set wsTarget = ThisWorkbook.Worksheets("Sheet2")
'array includes both columns: arrsource(1,1) = A2, arrsource(1,2) = B2
Dim arrSource As Variant
arrSource = wsSource.Range("A1").CurrentRegion.Offset(1)
Dim rgTarget As Range
Set rgTarget = wsTarget.Range("A1").CurrentRegion.Offset(1)
Dim i As Long
For i = 1 To UBound(arrSource, 1) 'ubound gives you the upper bound of the array
rgTarget.Replace arrSource(i, 1), arrSource(i, 2)
Next
End Sub

How can I copy a column of cells in excel, with VBA, until there is a blank and paste it into a new sheet?

I am looking to deal with a couple of problems here:
We have a spreadsheet from a client that consists of 150 odd tabs of the same daily work form. In each work form, thankfully in the same positions, are a date in C4 and a list of works carried out starting in B10.(the works carried out vary in a number of cells; some have 3 some have 8 etc... so a list
redacted sheet, partial
What I need to do is, copy the works carried out into the database sheet, Column B, then copy the date from C4 (in the works sheet) into column A (of the database sheet), for each one of the works carried out. (so if there are 5 tasks carried out it would copy in the date to Column A 5 times. I then need to do that for all the tabs, so it is in one list.
There is a gap below the list of works of 1 cell then more data, this is the same above... noit sure if End(xlUp) or End(xldown)would be usable.
multiple tabs macro - the issue is it copies to each tab, not a single tab
Sub DateCLM()
DateCLM Macro
Date Column
Dim xSh As Worksheet
Application.ScreenUpdating = False
For Each xSh In Worksheets
xSh.Select
Call RunCode
Next
Application.ScreenUpdating = True
End Sub
Currently trying to figure this out and not getting anywhere.. any help would be appreciated.
Matt
How can I copy a column of cells in excel, with VBA, until there is a
blank and paste it into a new sheet?
Here is an algorithm I came up with years ago to solve this problem.
Create variables for the first and last cells in your range
Set the value of the first cell in the range, i.e. B10
Select the first cell in the range
While active cell is not empty
select the next cell down
end while
select the range of cells between your two variables
---perform some action---
I don't have access to the original file, nor have I used VBA for years, but I've given it a go. Hopefully this will give you a help in the right direction?
Sub selectRange()
'Create variables for the first and last cells in your range
Dim firstCell As Range
Dim lastCell As Range
'Set the value of the first cell in the range, i.e. B10
firstCell = Range("B10")
'Select the first cell in the range
firstCell.Select
firstCell.Activate
'Loop while cell is empty
While Not ActiveCell = ""
ActiveCell.Offset(1, 0).Activate
Wend
'After empty cell is found, activate last non-empty cell
ActiveCell.Offset(-1, 0).Activate
lastCell = ActiveCell
'Select the range of cells between your two variables
ActiveSheet.Range(firstCell, lastCell).Select
'---perform some action---
End Sub
Copy From Multiple Worksheets
It is assumed that the data is consistent:
Database is a worksheet in the same workbook as the worksheets to be processed,
all dates are in cell C4 and are actual dates,
all other data is located from cell B10 to before (above) the first blank cell below.
Adjust the values in the constants section.
The Code
Option Explicit
Sub copyFromMultipleWorksheets()
Const wsName As String = "Database"
Const wsCell As String = "A2"
Const datesCell As String = "C4"
Const worksFirstCell As String = "B10"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsCount As Long: wsCount = wb.Worksheets.Count
' Define Arrays.
Dim Works As Variant: ReDim Works(1 To wsCount - 1)
Dim Dates() As Date: ReDim Dates(1 To wsCount - 1)
Dim RowsCount() As Long: ReDim RowsCount(1 To wsCount - 1)
Dim OneValue As Variant: ReDim OneValue(1 To 1, 1 To 1)
' Declare additional variables.
Dim ws As Worksheet ' Source Worksheet
Dim rg As Range ' Source Range
Dim rCount As Long ' Rows Count
Dim tRows As Long ' Total Rows (for Data Array)
Dim n As Long ' Worksheets, Dates, Works Arrays, RowCounts Counter
For Each ws In wb.Worksheets
If ws.Name <> wsName Then
' Define Works Range.
With ws.Range(worksFirstCell)
Set rg = .Resize(.Worksheet.Rows.Count - .Row + 1)
Set rg = rg.Find("", rg.Cells(rg.Rows.Count), xlFormulas)
Debug.Print rg.Address
Set rg = .Resize(rg.Row - .Row)
End With
' Count, write date and count some more.
n = n + 1
Dates(n) = ws.Range(datesCell).Value
rCount = rg.Rows.Count
RowsCount(n) = rCount
tRows = tRows + rCount
' Write values from Works Range to current array of Works Array.
If rCount > 1 Then
Works(n) = rg.Value
Else
Works(n) = OneValue: Works(n)(1, 1) = rg.Value
End If
End If
Next ws
' Write values from arrays of Works Array to Data Array.
Dim Data As Variant: ReDim Data(1 To tRows, 1 To 2)
Dim i As Long, k As Long
For n = 1 To n
For i = 1 To RowsCount(n)
k = k + 1
Data(k, 1) = Dates(n)
Data(k, 2) = Works(n)(i, 1)
Next i
Next n
' Write values from Data Array to Destination Range.
With wb.Worksheets(wsName).Range(wsCell).Resize(, 2)
Application.ScreenUpdating = False
.Resize(.Worksheet.Rows.Count - .Row + 1).ClearContents
.Resize(k).Value = Data
Application.ScreenUpdating = True
End With
' Inform user.
MsgBox "Data transferred.", vbInformation, "Success"
End Sub

Assign Different Formulas To Cells According By Criteria

I have written a code in which I am trying to use two different formulas with a set of conditions like if we take RUZ currency into consideration. where we have tenors between (SW- 1Y), the formula should be =1/(1/R208C[-5]+RC12/10000) and for the rest of the tenors (2Y, 3Y,5Y) the formula should be =1*RC[-5]. this condition is only applicable on RUZ ccy, for the rest, one formula per ccy(currency) will be used for all their respective tenors.
the formula is placed in column P,
tenors are placed in column B
Sub Get_vpl()
' Define Constants.
Const wsName As String = "DS"
Const FirstRow As Long = 5
Const srcCol As String = "A"
Const tgtCol As String = "P"
Dim Criteria As Variant
Dim Formulas As Variant
Criteria = Array("RUB", "TRY", "TWD", "UAH", "UYU", "VND") ' add more...
Formulas = Array( "=1/(1/R208C[-5]+RC12/10000)", "=1*RC[-5]", "=1/(1/R232C[-5]+RC12/1)", "=1*RC[-5]", "=1*RC[-5]", "=1*RC[-5]") ' add more...
' Define the Source Column Range.
' Define workbook.
Dim wb As Workbook
Set wb = ThisWorkbook
' Define worksheet.
Dim ws As Worksheet
Set ws = wb.Worksheets(wsName)
' Calculate Last Non-Empty Row.
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, srcCol).End(xlUp).Row
' Define Source Column Range.
Dim rng As Range
Set rng = ws.Range(ws.Cells(FirstRow, srcCol), ws.Cells(LastRow, srcCol))
' Prepare to write to Target Column Range.
' Calculate Column Offset.
Dim ColOffset As Long
ColOffset = ws.Columns(tgtCol).Column - ws.Columns(srcCol).Column
' Declare variables.
Dim CurPos As Variant ' Current Position
Dim cel As Range ' Current Cell Range
' Write formulas to Target Column Range.
Application.ScreenUpdating = False
' Iterate the cell ranges in Source Range.
For Each cel In rng.Cells
' Check if Current Cell Range in Source Column Range is not empty.
If Not IsEmpty(cel) Then
' Try to find the value in Current Cell Range in Criteria Array
' and write the position to Current Position
CurPos = Application.Match(cel, Criteria, 0)
' Check if value in Current Cell Range has been found
' in Criteria Array.
If Not IsError(CurPos) Then
' Write formula from Formulas Array to current Target Cell
' Range, using Current Position in Criteria Array.
cel.Offset(, ColOffset).Formula = _
Application.Index(Formulas, CurPos)
End If
End If
Next cel
Application.ScreenUpdating = True
End Sub
I have done more than intended to your code because I had so much difficulty understanding what you need. However, I'm rather pleased with the result and hope you will be, too. Note that I never ran the code and it may, therefore, contain minor bugs or typos which I shall be happy to rectify if you point them out.
Option Explicit
Enum Nws ' worksheet navigation
NwsFirstRow = 5
NwsCcy = 1 ' Columns: A = Currency
NwsTenor ' B = Tenor
NwsTarget = 16 ' P = Target
End Enum
Sub Get_vpl()
' 116
' Define Constants.
Const wsName As String = "DS"
' Declare variables.
Dim Wb As Workbook
Dim Ws As Worksheet
Dim CcyIdx As Integer ' return value from CurrencyIndex()
Dim R As Long ' loop counter: rows
Set Wb = ThisWorkbook
Set Ws = Wb.Worksheets(wsName)
Application.ScreenUpdating = False
With Ws
' this syntax is easier because you need the row number R
For R = NwsFirstRow To .Cells(.Rows.Count, NwsCcy).End(xlUp).Row
CcyIdx = CurrencyIndex(.Cells(R, NwsCcy).Value)
If CcyIdx >= 0 Then
.Cells(R, NwsTarget).Formula = ChooseFormula(CcyIdx, .Cells(R, NwsTenor).Value)
End If
Next R
End With
Application.ScreenUpdating = True
End Sub
Private Function ChooseFormula(ByVal CcyIdx As Integer, _
ByVal Tenor As String) As String
' 116
' return the formula specified by Idx or Formula(0)
Dim Idx As Integer
Dim Formula(2) As String
' the advantage of the syntax you chose is that the array
' is dimensioned automatically.
' Here the advantage is clarity.
Formula(0) = "=1*RC[-5]"
Formula(1) = "=1/(1/R208C[-5]+RC12/10000)"
Formula(2) = "=1/(1/R232C[-5]+RC12/1)"
If CcyIdx = 0 Then
If InStr("1Y,2Y,3Y,5Y", Tenor) Then Idx = 1
End If
ChooseFormula = Formula(Idx)
End Function
Private Function CurrencyIndex(ByVal Currcy As String) As Integer
' 116
' return -1 if not found or blank
Dim Ccy() As String ' list of currencies
Dim i As Integer
' I added "RUZ" in position 0 (change to suit and match in ChooseFormula())
' this syntax uses less space but doesn't support MATCH()
Ccy = Split("RUZ RUB TRY TWD UAH UYU VND") ' add more...
If Len(Trim(Currcy)) Then
For i = UBound(Ccy) To 0 Step -1
If StrComp(Currcy, Ccy(i), vbTextCompare) = 0 Then Exit For
Next i
Else
i = -1
End If
CurrencyIndex = i
End Function
I found your Criteria rather useless in this context. Perhaps that's why I gave it a task. The function CurrencyIndex() returns the index number of the current currency and uses this number thereafter in place of the actual currency code. For this purpose I added "RUZ" to your array. I have it in first position but any other number will do as well.
Please look at the function ChooseFormula(). It seems you have only 3 formulas. I assigned the index 0 to the most common one and made that the default. For the rest of it, the CcyIdx is passed to the function as an argument and if that index = 0 it identifies "RUZ" and gives it special treatment. I'm not sure that the treatment I assigned is 100% correct or workable but I think the code is simple and you should be able to modify it as required. Observe that the function won't ever return Formula(2) in its present state but you can modify it easily to accommodate all kinds of conditions and many more possible formulas. Let me know if you need any help with that.

VBA Excel: Trying to name dynamic ranges organized into rows

I have data organized into rows and in column B I have data titles. I want to select the data after the titles and then give them range names based on that title. I was able to code a solution that could name column ranges dynamically this way, but when altering it to name the rows of data I run into a 1004 error, specifically at the rng.CreateNames point.
Sub RowNames()
Dim ws As Worksheet, firstCol As Long, lastCol As Long, rowNum As Long, r As Integer, n As Integer, rng As Range, rngName As Range
Set ws = ThisWorkbook.Sheets("MonthlySales")
Set rng = ws.Range("B2:N41")
For n = 1 To rng.Rows.Count
For r = rng.Columns.Count To 1 Step -1
rowNum = rng.Rows(n).Row
firstCol = rng.Columns(1).Column
lastCol = rng.Columns(r).Column
If Cells(firstCol, rowNum).Value <> "" Then
Set rngName = Range(Cells(firstCol, rowNum), Cells(lastCol, rowNum))
rngName.CreateNames Left:=True
Exit For
End If
Next r
Next n
End Sub
Naming Row Ranges
Range.CreateNames Method
Frankly, never heard of it. Basically, in this case, you take a range and write different names in its first column and when you loop through the rows, for each row you write something like Range("A1:D1").CreateNames Left:=True to create a named range whose name is the value in A1 and it will refer to the range B1:D1.
To mix it up, this example (I think OP also) assumes that there might be blank cells in the first column, and the number of cells in each row range may vary. Each row range will be checked backwards for a value which will define its size.
The Code
Option Explicit
Sub RowNames()
' Define worksheet.
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("MonthlySales")
' Define Source Range.
Dim rng As Range
Set rng = ws.Range("B2:N41")
' Define Columns Count.
Dim ColumnsCount As Long
ColumnsCount = rng.Columns.Count
Dim RowRange As Range ' Current Row Range
Dim r As Long ' Source Range Rows Counter
Dim c As Long ' Source Range / Current Row Range Columns Counter
' Loop through rows of Source Range.
For r = 1 To rng.Rows.Count
' Create a reference to the current Row Range.
Set RowRange = rng.Rows(r)
' Check if first cell of current Row Range contains a value,
' making it a possible candidate for a defined name.
If RowRange.Cells(1).Value <> "" Then
' Loop through cells (columns) of current Row Range backwards.
For c = ColumnsCount To 2 Step -1
' Check if current cell in current Row Range contains a value.
If RowRange.Cells(c) <> "" Then
' Create a named range from value in first cell. The range
' is defined from the second cell to to current cell
' in current Row Range.
RowRange.Cells(1).Resize(, c).CreateNames Left:=True
' Exit loop, we got what we came for (the named range).
Exit For
End If
Next c
End If
Next r
End Sub

Copy and paste acording to number of another workbook row

i have two workbooks named "main" and "temp" . in workbook "temp" i have 2 sheets. i wanna write a macro that in a loop from A1 TO A1000, search cell A(x,1) VALUE from workbook "main" in workbook"temp" sheet"1" and if find it , then copy and paste entire row in workbook"temp" sheet"2". i write below code. but two problem exsits:
1- i wanna copy the the entire row found in workbook "temp" sheet1 in sheet 2 according to workbook "main" row number not workbook"temp" row number. i mean if text:book is in A(1,1) cell in workbook "main" and found it in A(9,1) in workbook"temp".sheet1 copy its entire row and paste it in sheet2 in row 1 not row 9.
2-i write macro in workbook"temp" and have a button to run this macro- but when i am in sheet2 macro don't work well but when i am in sheet1 its works well.
please help me find problems...thanks
Sub sorting()
Dim coname As String
Dim counter As Integer
Dim cell As Range
For counter = 1 To 1000
coname = Workbooks("main").Worksheets("statics").Cells(counter, 1)
With Workbooks("temp").Worksheets(1)
For Each cell In Range("a1", Range("a1").End(xlDown))
If cell.Value = coname Then
Rows(cell.Row).Copy Destination:=Workbooks("temp").Sheets(2).Rows(cell.Row)
End If
Next cell
End With
Next counter
End Sub
1.
I would change coname to be a Range data type (Dim coname As Range) and then slightly change your code like so:
If cell.Value = coname.Value Then
coname.EntireRow.Copy Destination:=Workbooks("temp").Sheets(2).cell
End If
By changing the datatype, we can now refer to the correct row (on the correct sheet) using the EntireRow property of the coname Range object.
Previously you were getting the wrong row because your source data was using the Cell.Row property to get the row to copy from, but that is your destination reference, so changing it to coname now points the source data to the right range.
2.
Use explicit qualification to your workbook/worksheets! Currently the issue of where you call the code from is due to this line: For Each cell In Range("a1", Range("a1").End(xlDown)).
Because you haven't lead the Range() reference with a ., it's not making use of the With statement it's within! So it translates to ActiveSheet.Range("A1"...). Put a . in front of Range to use your With statement and it will be Workbooks("temp").Worksheets(1).Range("A1"...).
After that it won't matter where/how you call the code, it will always refer to the correct sheet!
Three Sheets in Play
Carefully adjust the constants to fit your needs.
Especially take care of srcLastColumn which wasn't mentioned in
your question. You don't want to copy the whole range, just the range
containing values.
The complete code goes into a standard module (e.g. Module1).
What the code emulates would be something like the following:
In the Main Worksheet loops through a column and reads the values row
by row.
It compares each of the value with each of the values in a column in
the Source Worksheet.
If it finds a match it writes the complete row containing values from
Source Worksheet to the same row as the row of Main Worksheet,
but to the row in Target Worksheet.
Then it stops searching and goes to the next row in Main Worksheet.
The Code
Option Explicit
Sub Sorting()
Const mFirst As String = "A1" ' First Cell in Main or Target
Const mWbName As String = "main.xlsx" ' The workbook has to be open.
Const mWsName As String = "statics"
Const srcNameOrIndex As Variant = 1 ' It is safer to use the Sheet Name.
Const srcFirst As String = "A1" ' First Cell in Source
Const srcLastColumn As Long = 5 ' !!! Source Last Column !!!
Const tgtNameOrIndex As Variant = 2 ' It is safer to use the Sheet Name.
' Write values from Main and Source Worksheets to Main and Source Arrays.
Dim mn As Worksheet: Set mn = Workbooks(mWbName).Worksheets(mWsName)
Dim Main As Variant ' Main Array
Main = getColumn(mn, mn.Range(mFirst).Column, mn.Range(mFirst).Row)
If IsEmpty(Main) Then Exit Sub
Dim src As Worksheet: Set src = ThisWorkbook.Worksheets(srcNameOrIndex)
Dim Source As Variant ' Source Array
Source = getColumn(src, src.Range(srcFirst).Column, src.Range(srcFirst).Row)
If IsEmpty(Source) Then Exit Sub
Dim rng As Range
Set rng = src.Range(srcFirst).Resize(UBound(Source), _
srcLastColumn - src.Range(srcFirst).Column + 1)
Source = rng: Set rng = Nothing
' Write values from Source Array to Target Array.
Dim ubM As Long: ubM = UBound(Main)
Dim ubS1 As Long: ubS1 = UBound(Source)
Dim ubS2 As Long: ubS2 = UBound(Source, 2)
Dim Target As Variant ' Target Array
ReDim Target(1 To ubM, 1 To ubS2)
Dim i As Long, k As Long, l As Long, Criteria As String
For i = 1 To ubM
Criteria = Main(i, 1)
For k = 1 To ubS1
If Source(k, 1) = Criteria Then
For l = 1 To ubS2
Target(i, l) = Source(k, l)
Next l
Exit For
End If
Next k
Next i
' Write values from Target Array to Target Worksheet.
Dim tgt As Worksheet: Set tgt = ThisWorkbook.Worksheets(tgtNameOrIndex)
tgt.Range(mFirst).Resize(ubM, ubS2) = Target
' Inform user.
MsgBox "Data successfully transfered.", vbInformation, "Success"
' If you don't see this message, nothing has happened.
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Writes the values of a one-column range to a 2D one-based '
' one-column or one-row array. '
' Returns: A 2D one-based one-column or one-row array. '
' Remarks: The cells below the column range have to be empty. '
' If an error occurs the function will return an empty variant. '
' Therefore its result can be tested with "IsEmpty". '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function getColumn(Sheet As Worksheet, ByVal AnyColumn As Variant, _
Optional ByVal FirstRow As Long = 1, _
Optional ByVal transposeResult As Boolean = False, _
Optional ByVal showMessages As Boolean = False) As Variant
Const Proc As String = "getColumn"
On Error GoTo cleanError
Dim rng As Range
Set rng = Sheet.Columns(AnyColumn).Find("*", , xlFormulas, , , xlPrevious)
If rng Is Nothing Then Exit Function
If rng.Row < FirstRow Then Exit Function
Set rng = Sheet.Range(Sheet.Cells(FirstRow, AnyColumn), rng)
If Not rng Is Nothing Then
If Not transposeResult Then
getColumn = rng
Else
getColumn = Application.Transpose(rng)
End If
End If
Exit Function
cleanError:
If showMessages Then
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
End If
On Error GoTo 0
End Function

Resources