Bạn thay code sau thử, kg có can đảm để test với 200 cột. Cố gắng sẽ tối ưu hơn mà giờ chưa nghĩ ra.
PHP:
Option Explicit
Dim endR As Long, endC As Long, iR As Long, fR As Long, sodong As Long
Dim i As Long, j As Long, k As Long, m As Long, s As Long, socot As Long
Dim MyRng As Range, Arr(), ArrCapSo(), ArrKQ1(), ArrKQ2(), ArrKQ3()
Dim sCapSo1 As String, sCapSo2 As String
Sub TaoCapSo()
fR = 4
With Sheet1
endR = .Cells(65000, 2).End(xlUp).Row
endC = .Cells(fR, 1000).End(xlToLeft).Column
Set MyRng = .Range("B" & fR).Resize(endR - fR + 1, endC - 1)
Arr = MyRng
End With
socot = UBound(Arr, 2) - 1
ReDim ArrCapSo(1 To MyRng.Rows.Count, 1 To socot)
iR = 1: s = 0
Do While iR < MyRng.Rows.Count + 1
If MyRng(iR, 1).Interior.Color <> 16777215 Then
s = s + 1
For k = 1 To socot
ArrCapSo(s, k) = CStr(MyRng(iR, k + 1) & "-" & MyRng(iR + 1, k + 1))
Next k
iR = iR + 2
Else
iR = iR + 1
End If
Loop
Set MyRng = Nothing
End Sub
Sub DemCapSo()
With Application
.ScreenUpdating = False: .DisplayAlerts = False
End With
Dim T
T = Timer
TaoCapSo
sodong = s
For k = 1 To socot
ReDim ArrKQ1(1 To UBound(Arr, 1) * (UBound(Arr, 1) - 1), 1 To 1)
ReDim ArrKQ2(1 To UBound(Arr, 1) * (UBound(Arr, 1) - 1), 1 To 1)
ReDim ArrKQ3(1 To UBound(Arr, 1) * (UBound(Arr, 1) - 1), 1 To 1)
s = 0
For i = 1 To UBound(Arr, 1) - 1
For j = i + 1 To UBound(Arr, 1)
s = s + 1
sCapSo1 = CStr(Arr(i, k) & "-" & Arr(j, k))
sCapSo2 = CStr(Arr(j, k) & "-" & Arr(i, k))
For m = 1 To sodong 'so dong cua arrcapso'
If ArrCapSo(m, k) = sCapSo1 Then ArrKQ1(s, 1) = ArrKQ1(s, 1) + 1
If ArrCapSo(m, k) = sCapSo2 Then ArrKQ2(s, 1) = ArrKQ2(s, 1) + 1
Next m
ArrKQ3(s, 1) = ArrKQ1(s, 1) + ArrKQ2(s, 1)
Next j
Next i
'gan vao'
With Sheets(2)
.Range("B4").Offset(, k - 1).Resize(s, 1) = ArrKQ3
End With
With Sheets(3)
.Range("B4").Offset(, k - 1).Resize(s, 1) = ArrKQ1
End With
With Sheets(4)
.Range("B4").Offset(, k - 1).Resize(s, 1) = ArrKQ2
End With
Erase ArrKQ1, ArrKQ2, ArrKQ3
Next k
Erase ArrCapSo, Arr
With Application
.ScreenUpdating = True: .DisplayAlerts = True
End With
MsgBox Timer - T
End Sub
