Public Const WSNAME = "TONG HOP"
Function SheetExist(ByVal SheetName As String) As Boolean
On Error Resume Next
SheetExist = Not Sheets(SheetName) Is Nothing
End Function
Function Join2DArray(ParamArray arrays())
Dim arr(), aSub, tmp
Dim lRs As Long, lCs As Long, lR As Long, lC As Long
Dim n As Long, m As Long, i As Long, bChk As Boolean
On Error Resume Next
For i = 0 To UBound(arrays)
aSub = arrays(i)
n = UBound(aSub, 1) - LBound(aSub, 1) + 1
lRs = lRs + n
m = UBound(aSub, 2) - LBound(aSub, 2) + 1
If lCs < m Then lCs = m
Next
ReDim arr(1 To lCs, 1 To lRs)
n = 0: m = 0
For i = 0 To UBound(arrays)
aSub = arrays(i)
For lR = LBound(aSub, 1) To UBound(aSub, 1)
bChk = False
n = n + 1
For lC = LBound(aSub, 2) To UBound(aSub, 2)
tmp = aSub(lR, lC)
Select Case VarType(tmp)
Case 0 To 1: arr(lC, n) = vbNullString
Case 2 To 7: arr(lC, n) = tmp
Case 8
If IsNumeric(tmp) Then
arr(lC, n) = "'" & tmp
Else
arr(lC, n) = tmp
End If
End Select
If Len(CStr(tmp)) Then bChk = True
Next
If bChk = False Then n = n - 1
Next
Next
If n Then
ReDim Preserve arr(1 To lCs, 1 To n)
Join2DArray = Transpose2DArray(arr)
End If
End Function
Function Transpose2DArray(ByVal arr2D)
Dim arr(), aTemp
Dim lR As Long, lC As Long
On Error Resume Next
aTemp = arr2D
ReDim arr(LBound(aTemp, 2) To UBound(aTemp, 2), LBound(aTemp, 1) To UBound(aTemp, 1))
For lR = LBound(aTemp, 1) To UBound(aTemp, 1)
For lC = LBound(aTemp, 2) To UBound(aTemp, 2)
arr(lC, lR) = aTemp(lR, lC)
Next
Next
Transpose2DArray = arr
End Function
Sub Main()
Dim aRes, wks As Worksheet
aRes = Join2DArray(Sheets("Part1").Range("A2:K1000"), Sheets("Part2").Range("A2:K1000"))
If IsArray(aRes) Then
If Not SheetExist(WSNAME) Then Worksheets.Add.Name = WSNAME
Set wks = Sheets(WSNAME)
wks.Range("A1:K1").Value = Sheets("Part1").Range("A1:K1").Value
wks.Range("A2").Resize(UBound(aRes, 1), UBound(aRes, 2)).Value = aRes
End If
End Sub
