Public Sub TongHop()
Application.ScreenUpdating = False
Dim Sh As Worksheet
Dim Arr(), Res(), SheetName(), Sht(), Result
Dim i As Long, k As Long, x As Long
Set Sh = ThisWorkbook.Worksheets(Sheet4.Name)
SheetName = Array(Sheet1.Name, Sheet2.Name, Sheet3.Name)
Call GetSheetName(SheetName, Sht())
For x = 1 To UBound(Sht)
With Sheets(Sht(x))
Arr = .Range("A1", .[A65536].End(3).Resize(, 2)).Value
End With
For i = 1 To UBound(Arr)
If Arr(i, 1) <> Empty Then
k = k + 1
ReDim Preserve Res(1 To 2, 1 To k)
Res(1, k) = Arr(i, 1)
Res(2, k) = Arr(i, 2)
End If
Next
Next
If k Then
Result = SplitArr2D(TransposeArr2D(Res))
With Sh.Range("A1")
.Resize(65536, 6).ClearContents
.Resize(UBound(Result, 1), 6) = Result
End With
End If
'Call ChangeFont(Sh, Range("A1"))
'Call FixColumnsRows(Sh)
Application.ScreenUpdating = True
End Sub
'---------------'
Private Function TransposeArr2D(ByVal arSrc)
Dim Arr, Result(), maxC As Long, j As Long, k As Long
Arr = arSrc
maxC = UBound(Arr, 1)
ReDim Result(1 To UBound(Arr, 2), 1 To maxC)
For k = 1 To UBound(Arr, 2)
For j = 1 To maxC
Result(k, j) = Arr(j, k)
Next j
Next k
TransposeArr2D = Result
End Function
'---------------'
Private Function SplitArr2D(ByVal arSrc)
Rem == chia mang 2 chieu thanh 3 phan
If IsArray(arSrc) = False Then Exit Function
Dim Arr, Result(), maxR As Long, N As Long, d As Long
Dim i As Long, j As Long, k As Long
Arr = arSrc
maxR = UBound(Arr, 1)
N = WorksheetFunction.Quotient(maxR, 3)
d = maxR Mod 3
ReDim Result(1 To N + 1, 1 To 6)
j = 1: k = 1
For i = 1 To UBound(Arr, 1)
Select Case d
Case 0, 1
Result(j, k) = Arr(i, 1)
Result(j, k + 1) = Arr(i, 2)
j = j + 1
If i Mod N = 0 Then j = 1: k = k + 2
Case 2
Result(j, k) = Arr(i, 1)
Result(j, k + 1) = Arr(i, 2)
j = j + 1
If i = N Then j = 1: k = k + 2
If i = 2 * N + 1 Then j = 1: k = k + 2
End Select
Next i
SplitArr2D = Result
End Function