Combine & Concatenate
Скопируйте все четыре процедуры в стандартный модуль. Запустите только первую подпрограмму, которая вызовет остальные три функции.
Option Explicit
' Run only this. Adjust the seven consecutive constants as you see fit.
Sub Combine()
Const Proc As String = "Combine"
On Error GoTo cleanError
Const srcName As String = "Sheet1"
Const FirstRow As Long = 1
Const FirstColumn As Variant = 2
Const CombineColumn As Variant = 1
Const tgtName As String = "Sheet1"
Const tgtFirstCell As String = "E1"
Const Concatenator As String = ""
Dim wsSource As Worksheet ' Source Worksheet
Dim wsTarget As Worksheet ' Target Worksheet
Dim First As Variant ' First Column Array
Dim Combine As Variant ' Combine Column Array
Dim Target As Variant ' Target Array
Dim isWritten As Boolean ' Write Checker
Set wsSource = ThisWorkbook.Worksheets(srcName)
' Write Column Ranges to Column Arrays.
First = getColumn(wsSource, FirstColumn, FirstRow)
Combine = getColumn(wsSource, CombineColumn, FirstRow)
' Combine Column Arrays to Target Array.
If IsEmpty(First) Or IsEmpty(Combine) Then Exit Sub
Target = combineColumns(First, Combine, Concatenator)
' Write Target Array to Target Range
Set wsTarget = ThisWorkbook.Worksheets(tgtName)
isWritten = writeToFirstCell(Target, wsTarget, tgtFirstCell)
'Inform user.
If isWritten Then
MsgBox "Data successfully transferred.", vbInformation
Else
MsgBox "Data not transferred.", vbExclamation
End If
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
On Error GoTo 0
End Sub
' Writes the values of a non-empty worksheet column range
' to a 2D one-based one-column array.
Function getColumn(Sheet As Worksheet, _
ByVal ColumnNumberOrLetter As Variant, _
Optional ByVal FirstRow As Long = 1) As Variant
Dim rng As Range
Set rng = Sheet.Columns(ColumnNumberOrLetter) _
.Find("*", , xlFormulas, , , xlPrevious)
If rng Is Nothing Then Exit Function
If rng.Row < FirstRow Then Exit Function
getColumn = Sheet.Range(Sheet.Cells(FirstRow, ColumnNumberOrLetter), rng)
End Function
' Combines two 2D one-based one-column arrays to another 2D one-based array.
' First the first element of FirstColumn will be combined (concatenated)
' with each element of CombineColumn (in the first column of resulting array),
' then the second element of FirstColumn ...etc. The resulting array will have
' as many rows as elements in CombineColumn and as many columns as elements
' in FirstColumn.
Function combineColumns(ByVal FirstColumn As Variant, _
ByVal CombineColumn As Variant, _
Optional ByVal Concatenator As String = "") As Variant
Dim i As Long, j As Long, k As Long
ReDim Target(1 To UBound(CombineColumn), _
1 To UBound(FirstColumn))
For j = 1 To UBound(FirstColumn)
For i = 1 To UBound(CombineColumn)
Target(i, j) = FirstColumn(j, 1) _
& Concatenator & CombineColumn(i, 1)
Next i
Next j
combineColumns = Target
End Function
' Writes a 2D one-based array to a worksheet.
Function writeToFirstCell(Source2D1B As Variant, Sheet As Worksheet, _
Optional ByVal FirstCellAddress = "A1") As Boolean
On Error GoTo exitProcedure
Sheet.Range(FirstCellAddress) _
.Resize(UBound(Source2D1B), UBound(Source2D1B, 2)) = Source2D1B
writeToFirstCell = True
Exit Function
exitProcedure:
End Function