Cảm ơn bạn, tất cả các số 31 tại các cột dồn về 1 cột nhưng chỉ cần dán 1 lần kết quả 31 thôi để mình biết là dữ liệu 31 là có mặt ở tất cả các cột!
Public Sub GPE()
Dim Dic As Object, Dem As Object, sArr(), tArr(), dArr(), Tem As String, Tem2 As String
Dim I As Long, J As Long, K As Long, C As Long, N As Long, R As Long, Rws As Long
Set Dic = CreateObject("Scripting.Dictionary")
Set Dem = CreateObject("Scripting.Dictionary")
With Sheet1
C = .Range("A1").SpecialCells(xlLastCell).Column - 1
R = .Range("A1").SpecialCells(xlLastCell).Row
sArr = .Range("B5:B" & R).Resize(, C).Value
End With
ReDim tArr(1 To UBound(sArr), 1 To 2)
ReDim dArr(1 To UBound(sArr), 1 To 1)
For I = 1 To UBound(sArr)
If sArr(I, 1) <> Empty Then
Tem = sArr(I, 1)
If Not Dic.Exists(Tem) Then
K = K + 1: Dic.Add Tem, K
tArr(K, 1) = sArr(I, 1)
tArr(K, 2) = 1
End If
End If
Next I
For J = 2 To UBound(sArr, 2)
Dem.RemoveAll
For I = 1 To UBound(sArr)
If sArr(I, J) <> Empty Then
Tem = sArr(I, J)
If Dic.Exists(Tem) Then
If Not Dem.Exists(sArr(I, J)) Then
Dem.Add sArr(I, J), ""
Rws = Dic.Item(Tem)
tArr(Rws, 2) = tArr(Rws, 2) + 1
End If
End If
End If
Next I
Next J
For I = 1 To K
If tArr(I, 2) = C Then
N = N + 1
dArr(N, 1) = tArr(I, 1)
End If
Next I
With Sheet2
'.Range("E5").Resize(K, 2) = tArr' 'Chi de quan sat'
.Range("B5").Resize(N) = dArr
.Range("B5").Resize(N).Sort Key1:=.Range("B5")
End With
Set Dic = Nothing
Set Dem = Nothing
End Sub-------------------------
góp thêm code
Sub SoTrung()
Dim Dic As Object
With Sheets("sheet1")
dArr = Range(.Cells(5, 2), .Cells(5, 2).End(xlDown))
Set Dic = CreateObject("Scripting.Dictionary")
ReDim arr(1 To UBound(dArr), 1 To 1)
lastcot = .Cells(5, 2).End(2).Column
On Error Resume Next
For I = 1 To UBound(dArr)
If Not Dic.Exists(dArr(I, 1)) Then
Dic.Add dArr(I, 1), ""
Tmp = 0
For J = 3 To lastcot
tim = Range(.Cells(5, J), .Cells(5, J).End(xlDown)).Find(dArr(I, 1), LookIn:=xlValues).Row
If tim > 0 Then Tmp = Tmp + 1
tim = 0
Next
If Tmp = lastcot - 2 Then
K = K + 1
arr(K, 1) = dArr(I, 1)
End If
End If
Next
End With
Sheets("sheet2").Cells(3, 2).Resize(K, 1) = arr
End SubPublic Sub GPE_2()
Dim Dic As Object, sArr(), tArr(), Tem As String
Dim I As Long, J As Long, K As Long, C As Long, R As Long, Rws As Long
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet1
C = .Range("A1").SpecialCells(xlLastCell).Column - 1
R = .Range("A1").SpecialCells(xlLastCell).Row
sArr = .Range("B5:B" & R).Resize(, C).Value
End With
ReDim tArr(1 To UBound(sArr), 1 To 2)
For I = 1 To UBound(sArr)
If sArr(I, 1) <> Empty Then
Tem = sArr(I, 1)
If Not Dic.Exists(Tem) Then
K = K + 1: Dic.Add Tem, K
tArr(K, 1) = sArr(I, 1)
tArr(K, 2) = 1
End If
End If
Next I
For J = 2 To UBound(sArr, 2)
For I = 1 To UBound(sArr)
If sArr(I, J) <> Empty Then
Tem = sArr(I, J)
If Dic.Exists(Tem) Then
Rws = Dic.Item(Tem)
If tArr(Rws, 2) + 1 = J Then
tArr(Rws, 2) = J
ElseIf tArr(Rws, 2) + 1 < J Then
Dic.Remove Tem
End If
End If
End If
Next I
Next J
With Sheet2
.Range("B5:B200").ClearContents
Rws = Dic.Count
If Rws Then
.Range("B5").Resize(Rws) = Application.WorksheetFunction.Transpose(Dic.Keys)
.Range("B5").Resize(Rws).Sort Key1:=.Range("B5"), Order1:=xlAscending
End If
End With
Set Dic = Nothing
End Sub
Sub Loc()
Dim ArrData, ArrCheck() As Boolean, I As Long, J As Long
ArrData = Sheet1.Range("B5").CurrentRegion.Value
ReDim ArrCheck(0 To 99, 1 To UBound(ArrData, 2))
For J = 1 To UBound(ArrData, 2)
For I = 1 To UBound(ArrData, 1)
If ArrData(I, J) = "" Then GoTo NextCol Else ArrCheck(CLng(ArrData(I, J)), J) = True
Next
NextCol:
Next
Sheet2.Range("B2:B101").ClearContents
For I = 0 To 99
For J = 1 To UBound(ArrCheck, 2)
If Not ArrCheck(I, J) Then GoTo NextNum
Next
Sheet2.Cells(101, 2).End(xlUp).Offset(1).Value = I
NextNum:
Next
End Sub
Sub choi()
Dim I As Integer, Query As String
For I = 2 To 33
Query = Query & " SELECT distinct f" & I - 1 & " FROM [B5:AK250] union all"
Next
Query = Left(Query, Len(Query) - 10)
Query = "select f1, count(f1) from (" & Query & ") group by f1 having count(f1) = 36"
Set cn = CreateObject("ADODB.Connection")
cn.Open ("Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0 Xml;HDR=NO"";")
Set rs = cn.Execute(Query)
Sheets(2).Range("D1").CopyFromRecordset rs
End SubMình chỉnh lại CT, lần này ok rồi, CT tại A1 sheet2:
A1=IFERROR(IF(SUM(LOOKUP(ROW($1:$36),SMALL(IF((--Sheet1!$B$5:$AK$245=ROW(A1)),COLUMN($A$4:$AJ$4)),ROW(INDIRECT("1:"&SUM((--Sheet1!$B$5:$AK$245=ROW(A1))*1))))))=666,ROW(A1),""),"")=INDEX(Sheet1!B:B;LARGE((MMULT(--(COUNTIF(OFFSET(Sheet1!B$5:B$245;;COLUMN(Sheet1!B:AK)-COLUMN(Sheet1!B:B));IF(MATCH(Sheet1!B$5:B$245;Sheet1!B:B;0)=ROW(Sheet1!B$5:B$245);Sheet1!B$5:B$245))>0);--TRANSPOSE(COLUMN(Sheet1!B:AK)>0))=COLUMNS(Sheet1!B:AK))*ROW(Sheet1!B$5:B$245);ROW(1:1)))Công thức này có lẽ nhanh hơn một tí
=IF(MAX(FREQUENCY(COLUMN($B$5:$AK$5),($B$5:$AK$219=TEXT(ROW(A1)-1,"00"))*COLUMN($B$5:$AK$5)))=1,ROW(A1)-1,"")00 thì chỉnh Row(a1)-1 là được thầy, CT thầy hay, để em tìm hiểu!!!
Public Sub XuatHien_AllColumn()
Dim sArr, dArr
Dim t, Tmp
Dim n As Long, i As Long, j As Long, k As Long, m As Long
Dim Dic As Object
t = Timer
Set Dic = CreateObject("scripting.dictionary")
m = Sheet1.[IV5].End(xlToLeft).Column - 1
With Sheet1
k = .[B65000].End(xlUp).Row
For j = 2 To m
i = .[B65000].Offset(0, j - 1).End(xlUp).Row
If k < i Then k = i
Next j
sArr = .[B5].Resize(k - 4 + 1, m)
End With
n = UBound(sArr)
j = 1
For i = 1 To UBound(sArr)
If sArr(i, j) <> "" Then
If Not Dic.Exists(sArr(i, j)) Then Dic.Add sArr(i, j), 1
End If
Next i
For j = 2 To m
For i = 1 To UBound(sArr)
If sArr(i, j) <> "" Then
If Dic.Exists(sArr(i, j)) Then
If Dic.Item(sArr(i, j)) = j - 1 Then Dic.Item(sArr(i, j)) = Dic.Item(sArr(i, j)) + 1
End If
End If
Next i
Next j
ReDim dArr(1 To k, 1 To 1)
j = 0
For Each Tmp In Dic.Keys
If Dic.Item(Tmp) = m Then
j = j + 1
dArr(j, 1) = Tmp
End If
Next
Set Dic = Nothing
Sheet2.[C3:C5000].ClearContents
Sheet2.[C3].Resize(j, 1) = dArr
MsgBox Round(Timer - t, 5)
End Sub
bạn chạy code
Sub SoTrung()
Dim Dic As Object, Arr, Darr(), i As Integer, j As Integer, tim As Integer, tmp As Integer
With Sheets("sheet2")
Range("C2:C101").ClearContents
Darr = Range(.Cells(2, 2), .Cells(2, 2).End(xlDown)).Resize(, 2)
ReDim Arr(1 To UBound(Darr), 1 To 1)
End With
With Sheets("sheet1")
lastcot = .Cells(5, 2).End(2).Column
On Error Resume Next
For i = 1 To UBound(Darr)
tmp = 0
For j = 2 To lastcot
tim = 0
tim = Range(.Cells(5, j), .Cells(5, j).End(xlDown)).Find(Darr(i, 1), LookIn:=xlValues).Row
If tim > 0 Then tmp = tmp + 1
Next
Arr(i, 1) = tmp
Next
End With
Sheets("sheet2").Cells(2, 3).Resize(i - 1) = Arr
End SubThay đổi code cũ theo y/c của bạn. code # để bạn tham khảo
Sub choi()
Dim I As Integer, Query As String
For I = 2 To 33
Query = Query & " SELECT distinct f" & I - 1 & " FROM [B5:AK250] union all"
Next
Query = "select f1, count(f1) from (" & Left(Query, Len(Query) - 10) & ") group by f1"
Set cn = CreateObject("ADODB.Connection")
cn.Open ("Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0 Xml;HDR=NO"";")
Set rs = cn.Execute(Query)
Sheets(2).Range("D1").CopyFromRecordset rs
End SubCT tại C2 sheet2:
C2=SUM((IFERROR(LOOKUP(ROW($1:$36),SMALL(IF(Sheet1!$B$5:$AG$245=B2,COLUMN($A$5:$AF$5)),ROW(INDIRECT("1:"&SUM((Sheet1!$B$5:$AG$245=B2)*1))))),0)=ROW($1:$36))*1)Thêm lựa chọn cho bạn (công thức mảng)
=SUM(--(MMULT(--TRANSPOSE(Sheet1!$B$5:$AG$245=B2),ROW(OFFSET($A$1,,,ROWS(Sheet1!$B$5:$AG$245))))>0))
