Làm phần 1 trước, do chưa hiểu yêu cầu.
Chỉ xét B4:B5 với các ô C tô màu thôi hay xét với D, E, F, G tô màu.
Phần 1 phần 2 đã tính tiếp sau. Nếu đếm B4:B5 trong các cặp ô tô màu B4:B5 thì kq gán vào B4 sh2, nếu B4:B6 kq là 5 thì gán vào B?, tương tự B5:B6 thì kq gán vào đâu.
Dim endR As Long, iR As Long, fR As Long, sodong As Long, dem1 As Long, dem2 As Long
Dim i As Long, j As Long, k As Long, m As Long, t As Long, s As Long, n As Long
Dim MyRng As Range, Arr(), ArrCapSo(), ArrKQ1(), ArrKQ2()
Dim sCapSo1 As String, sCapSo2 As String
Sub DemCapSo()
fR = 4
With Sheet1
endR = .Cells(65000, 2).End(xlUp).Row
Set MyRng = .Range("B" & fR & ":H" & endR)
Arr = MyRng
End With
ReDim ArrCapSo(1 To MyRng.Rows.Count, 1 To 5)
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 5
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
n = 1: sodong = s
For k = 1 To 2 'k =5
ReDim ArrKQ1(1 To 1000000, 1 To 1)
ReDim ArrKQ2(1 To 1000000, 1 To 1)
s = 0: t = 0
For i = 1 To UBound(Arr, 1) - 1
For j = i + 1 To UBound(Arr, 1)
sCapSo1 = CStr(Arr(i, k) & "-" & Arr(j, k))
sCapSo2 = CStr(Arr(j, k) & "-" & Arr(i, k))
'Luc nay moi xet dem theo ArrCapSo, chua xet cac cot C...'
dem1 = 0: dem2 = 0
For m = 1 To sodong 'so dong cua arrcapso'
If ArrCapSo(m, k) = sCapSo1 Then
dem1 = dem1 + 1
End If
If ArrCapSo(m, k) = sCapSo1 Or ArrCapSo(m, k) = sCapSo2 Then
dem2 = dem2 + 1
End If
Next m
If dem1 > 0 Then
s = s + 1
ArrKQ1(s, 1) = dem1
End If
If dem2 > 0 Then
t = t + 1
ArrKQ2(t, 1) = dem2
End If
Next j
Next i
'gan vao
With Sheets(n + 1)
If t > 0 Then
.Range("B4").Resize(t, 1) = ArrKQ2
End If
End With
With Sheets(n + 2)
If s > 0 Then
.Range("B4").Resize(s, 1) = ArrKQ1
End If
End With
n = n + 2
Erase ArrKQ1, ArrKQ2
Next k
Erase ArrCapSo, Arr
Set MyRng = Nothing
End SubVâng! Cảm ơn bạn!
Vấn đề là bạn xem code trên có ra kq có đúng không.
Ex 2007 chỉ có 1.048.576 dòng mà nếu lấy hết theo B4:B5, ... B4:B1203. => 1200 x 1199 = 1.438.800 dòng
Dim endR As Long, iR As Long, fR As Long, sodong As Long, dem1 As Long, dem2 As Long
Dim i As Long, j As Long, k As Long, m As Long, t As Long, s As Long, n As Long
Dim MyRng As Range, Arr(), ArrCapSo(), ArrKQ1(), ArrKQ2()
Dim sCapSo1 As String, sCapSo2 As String
Sub DemCapSo2()
fR = 4
With Sheet1
endR = .Cells(65000, 2).End(xlUp).Row
Set MyRng = .Range("B" & fR & ":H" & endR)
Arr = MyRng
End With
ReDim ArrCapSo(1 To MyRng.Rows.count, 1 To 5)
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 5
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
n = 1: sodong = s
For k = 1 To 1 'k =5
ReDim ArrKQ1(1 To 1048576, 1 To 1)
ReDim ArrKQ2(1 To 1048576, 1 To 1)
For i = 1 To UBound(Arr, 1) - 1
For j = i + 1 To UBound(Arr, 1)
s = (j - 1) + (i - 1) * UBound(Arr, 1)
sCapSo1 = CStr(Arr(i, k) & "-" & Arr(j, k))
sCapSo2 = CStr(Arr(j, k) & "-" & Arr(i, k))
'Luc nay moi xet dem theo ArrCapSo, chua xet cac cot C...'
dem1 = 0: dem2 = 0
For m = 1 To sodong 'so dong cua arrcapso'
If ArrCapSo(m, k) = sCapSo1 Then
dem1 = dem1 + 1
End If
If ArrCapSo(m, k) = sCapSo1 Or ArrCapSo(m, k) = sCapSo2 Then
dem2 = dem2 + 1
End If
Next m
If s = 1048576 - 4 Then GoTo Exit_Sub
If dem1 = 0 Then
ArrKQ1(s, 1) = ""
Else
ArrKQ1(s, 1) = dem1
End If
If dem2 = 0 Then
ArrKQ2(s, 1) = ""
Else
ArrKQ2(s, 1) = dem2
End If
Next j
'MsgBox s
Next i
'gan vao
Exit_Sub:
If s > 0 Then
With Sheets(n + 1)
.Range("B4").Resize(s, 1) = ArrKQ2
End With
With Sheets(n + 2)
.Range("B4").Resize(s, 1) = ArrKQ1
End With
End If
n = n + 2
Erase ArrKQ1, ArrKQ2
Next k
Erase ArrCapSo, Arr
Set MyRng = Nothing
End SubHì! Bạn àh! chỉ có: 1199+1198+...+2+1= (1200x1199):2= 719400 dòng thôi!
Hiểu rồi sửa code 1 chút về gán theo dòng s.
Dim endR As Long, iR As Long, fR As Long, sodong As Long, dem1 As Long, dem2 As Long
Dim i As Long, j As Long, k As Long, m As Long, t As Long, s As Long, n As Long
Dim MyRng As Range, Arr(), ArrCapSo(), ArrKQ1(), ArrKQ2()
Dim sCapSo1 As String, sCapSo2 As String
Sub DemCapSo2()
fR = 4
With Sheet1
endR = .Cells(65000, 2).End(xlUp).Row
Set MyRng = .Range("B" & fR & ":H" & endR)
Arr = MyRng
End With
ReDim ArrCapSo(1 To MyRng.Rows.count, 1 To 5)
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 5
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
n = 1: sodong = s
For k = 1 To 1 'k =5'
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)
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))
'Luc nay moi xet dem theo ArrCapSo, chua xet cac cot C...'
dem1 = 0: dem2 = 0
For m = 1 To sodong 'so dong cua arrcapso'
If ArrCapSo(m, k) = sCapSo1 Then
dem1 = dem1 + 1
End If
If ArrCapSo(m, k) = sCapSo1 Or ArrCapSo(m, k) = sCapSo2 Then
dem2 = dem2 + 1
End If
Next m
If dem1 = 0 Then
ArrKQ1(s, 1) = ""
Else
ArrKQ1(s, 1) = dem1
End If
If dem2 = 0 Then
ArrKQ2(s, 1) = ""
Else
ArrKQ2(s, 1) = dem2
End If
Next j
Next i
'gan vao'
With Sheets(n + 1)
.Range("B4").Resize(s, 1) = ArrKQ2
End With
With Sheets(n + 2)
.Range("B4").Resize(s, 1) = ArrKQ1
End With
n = n + 2
Erase ArrKQ1, ArrKQ2
Next k
Erase ArrCapSo, Arr
Set MyRng = Nothing
End SubOption Explicit
Dim endR As Long, iR As Long, fR As Long, sodong As Long, dem1 As Long, dem2 As Long, dem3 As Long
Dim i As Long, j As Long, k As Long, m As Long, s 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
Set MyRng = .Range("B" & fR & ":H" & endR)
Arr = MyRng
End With
ReDim ArrCapSo(1 To MyRng.Rows.Count, 1 To 5)
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 5
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 DemCapSo1()
Dim T
T = Timer
TaoCapSo
sodong = s
ReDim ArrKQ1(1 To UBound(Arr, 1) * (UBound(Arr, 1) - 1), 1 To 5)
ReDim ArrKQ2(1 To UBound(Arr, 1) * (UBound(Arr, 1) - 1), 1 To 5)
ReDim ArrKQ3(1 To UBound(Arr, 1) * (UBound(Arr, 1) - 1), 1 To 5)
For k = 1 To 5
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))
'Luc nay moi xet dem theo ArrCapSo, chua xet cac cot C...'
dem1 = 0: dem2 = 0: dem3 = 0
For m = 1 To sodong 'so dong cua arrcapso'
If ArrCapSo(m, k) = sCapSo1 Then
dem1 = dem1 + 1
End If
If ArrCapSo(m, k) = sCapSo1 Or ArrCapSo(m, k) = sCapSo2 Then
dem2 = dem2 + 1
End If
dem3 = dem2 - dem1
Next m
If dem1 = 0 Then 'AB'
ArrKQ1(s, k) = ""
Else
ArrKQ1(s, k) = dem1
End If
If dem2 = 0 Then 'AB or BA'
ArrKQ2(s, k) = ""
Else
ArrKQ2(s, k) = dem2
End If
If dem3 = 0 Then 'BA'
ArrKQ3(s, k) = ""
Else
ArrKQ3(s, k) = dem3
End If
Next j
Next i
Next k
'gan vao'
With Sheets(2)
.Range("B4").Resize(s, k - 1) = ArrKQ2
End With
With Sheets(3)
.Range("B4").Resize(s, k - 1) = ArrKQ1
End With
With Sheets(4)
.Range("B4").Resize(s, k - 1) = ArrKQ3
End With
Erase ArrKQ1, ArrKQ2, ArrKQ3
Erase ArrCapSo, Arr
MsgBox Timer - T
End SubCảm ơn bạn nhiều quá, mình không biết nói gì hơn!
200 cột hay X cột thì sửa những chỗ sau:
Thay những số 5 trên. Nhưng nên làm từ từ 10, 20...100, 200.
Vâng! Mình đã thay như bạn hướng dẫn với trường hợp là 10 cột, nhưng thấy báo lỗi và sau đó mình cũng thử bổ xung cả trường hợp:
nhưng cũng thấy báo cùng một lối: run-time erro "9"
- Mong phản hồi của bạn! Thân! Chúc buổi tối vui vẻ!
Hì! Mình hình như đã hiểu: không biết như thế này có đúng không? Nếu muốn tính toán cho 10 cột thì mình tiến thêm 2 cột nữa thay H thành M, 100 cột thì thay H thành CY,(và thay 5 thành các cột tương ứng) . . . Mình sẽ kiểm tra bằng cách cho chạy 5 cột rồi so với 10 cột có trùng kết quả cuối không?
Nếu mà 200 cột thì nên sửa lại code 1 chút. Thay vì ArrKQ lấy hết 200 cột và gán xuống thì mình gán từng cột sau đó lấy tiếp ...
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.
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 SubCảm ơn bạn! Mình đã test thử nhưng kết quả chỉ cho đến hàng 5671 thôi, còn thiếu rất nhiều bạn àh! Nhưng ngược lại thì tốc độ nhanh như chớp!
- Có thể nói rõ bạn đang test với bao nhiêu cột.
Bạn chạy thử code Sub DemCapSoNew() xem.
Code này chạy 10 cột hết 60s.
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, s As Long, socot As Long, t As Long
Dim MyRng As Range, Arr(), ArrCapSo(), ArrKQ1(), ArrKQ2(), ArrKQ3(), ArrTT(), ArrCS()
Dim sCapSo1 As String, sCapSo2 As String, sTmp As String
Dim Dic As Object
Sub LastRC()
fR = 4
With Sheet1
endR = .Cells(65000, 2).End(xlUp).Row
endC = .Cells(fR, 1000).End(xlToLeft).Column
End With
socot = endC - 1
sodong = endR - fR + 1
End Sub
Sub TaoArrTT()
LastRC
With Sheet1
Set MyRng = .Range("B" & fR).Resize(sodong, 1)
Arr = MyRng
End With
ReDim ArrTT(1 To UBound(Arr))
iR = 1: t = 0
Do While iR < UBound(Arr) + 1
If MyRng(iR, 1).Interior.Color <> 16777215 Then
t = t + 1
ArrTT(t) = iR
iR = iR + 2
Else
iR = iR + 1
End If
Loop
Set MyRng = Nothing
End Sub
Sub TaoArrCapSo()
With Sheet1
Set Dic = CreateObject("Scripting.Dictionary")
ArrCS = .Range("B" & fR).Offset(, k).Resize(sodong, 1)
Arr = .Range("B" & fR).Offset(, k - 1).Resize(sodong, 1)
ReDim ArrCapSo(1 To UBound(Arr), 1 To 2)
iR = 1: s = 0
For i = 1 To t 'UBound(ArrTT)'
sTmp = CStr(ArrCS(ArrTT(i), 1) & ArrCS(ArrTT(i) + 1, 1))
If Not Dic.Exists(sTmp) Then
s = s + 1
ArrCapSo(s, 1) = sTmp
Dic.Add sTmp, s
End If
ArrCapSo(Dic.Item(sTmp), 2) = ArrCapSo(Dic.Item(sTmp), 2) + 1
Next i
End With
End Sub
Sub DemCapSoNew01()
With Application
.ScreenUpdating = False: .DisplayAlerts = False
End With
Dim t
t = Timer
TaoArrTT
For k = 1 To socot - 1
TaoArrCapSo
ReDim ArrKQ1(1 To UBound(Arr) * (UBound(Arr) - 1), 1 To 1)
ReDim ArrKQ2(1 To UBound(Arr) * (UBound(Arr) - 1), 1 To 1)
ReDim ArrKQ3(1 To UBound(Arr) * (UBound(Arr) - 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, 1) & Arr(j, 1))
sCapSo2 = CStr(Arr(j, 1) & Arr(i, 1))
If Dic.Exists(sCapSo1) Then ArrKQ1(s, 1) = ArrCapSo(Dic.Item(sCapSo1), 2)
If Dic.Exists(sCapSo2) Then ArrKQ2(s, 1) = ArrCapSo(Dic.Item(sCapSo2), 2)
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, ArrCapSo, Arr, ArrCS
Set Dic = Nothing
If k Mod 20 = 0 Then ActiveWorkbook.Save
Next k
With Application
.ScreenUpdating = True: .DisplayAlerts = True
End With
MsgBox Timer - t
End SubHay là mình chạy 1 lần 200 cột
If Dic.Exists(sCapSo2) Then ArrKQ2(s, 1) = ArrCapSo(Dic.Item(sCapSo2), 2)
ArrKQ3(s, 1) = ArrKQ1(s, 1) + ArrKQ2(s, 1)'If Dic.Exists(sCapSo2) Then ArrKQ2(s, 1) = ArrCapSo(Dic.Item(sCapSo2), 2)
'ArrKQ3(s, 1) = ArrKQ1(s, 1) + ArrKQ2(s, 1)'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 WithOption Explicit
Sorry, mình sai 1 chút
'Phần sh 3 không đánh dấu.
Gán ArrKQ1 (AB) vào sh 3.
Bác ThuNghi ơi! Mấy hôm test code với 200 cột thì kết quả như sau: Với code ban đầu không vô hiệu phần gán (vẫn để kết quả ở sh2, sh3, sh4) thì mình chạy khoảng 9 tiếng mới được 79 cột (code vẫn chạy nhưng pause để kiểm tra thử vì sốt ruột quá (hì)), còn code có vô hiệu phần gán chỉ để kq1 (AB) ở sh3 như bác hướng dẫn thì khoảng 5 tiếng cũng không chờ được pause thì kết quả được 131 cột!
1/ Máy bạn chắc chậm quá rồi, phương án là làm lần 10 cột và copy sang file khác làm tiếp.
- Bạn Thunghi và các bạn thân mến! Mong các bạn xem giúp hộ mình trường hợp sau:
