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
