bạn đưa file lên xem thế nào
Thực sự mình chưa hiểu ý bạn. Bạn gửi file lên và nói rõ hơn nhé ! Cho ví dụ minh họa luôn nha bạn.
Chắc là tìm ra thì trưng địa chỉ ô ý luôn!
dạ đây là file mà e đã liệt kê tên bằng cách "Ctrl +f" và kê sang ô bên cạnh. Làm thế thì lâu quá.
Dạ. phải dùng VBA a. VBA thì e k lập được code rôi ạ
Bạn để thử code này trong module có tên sheet là "Sheet1" xem được không ạ:
Option Explicit
Private Sub CommandButton1_Click()
loc_va_dem_trung Me
End Sub
Private Sub loc_va_dem_trung(this_sheet As Worksheet)
Dim dict As Scripting.Dictionary, sKey As String, data()
Dim i As Long, r As Long, count As Long, sheet As Worksheet
Dim rng As Range: Set rng = this_sheet.Range("A1")
Dim r_ten As Range
r = this_sheet.Cells(this_sheet.Rows.count, "A").End(xlUp).Row
rng.Resize(r, 2).ClearContents
Set dict = New Scripting.Dictionary
For Each sheet In ThisWorkbook.Worksheets
If sheet.Name <> this_sheet.Name Then
Set r_ten = sheet.Range("B4")
r = sheet.Range(r_ten, r_ten.End(xlDown)).Rows.count - 1
data = r_ten.Offset(1).Resize(r)
For i = 1 To UBound(data, 1)
sKey = data(i, 1): count = 1
If dict.Exists(sKey) Then
dict(sKey) = dict(sKey) + 1
Else
dict.Add sKey, count
End If
Next i
End If
Next sheet
rng.Offset(0, 0).Value = "So lan trung"
rng.Offset(0, 1).Value = "Du lieu tim duoc"
rng.Offset(1, 0).Resize(dict.count).Value = WorksheetFunction.Transpose(dict.Items)
rng.Offset(1, 1).Resize(dict.count).Value = WorksheetFunction.Transpose(dict.Keys)
End Sub
Sao không xài 1 mảng kết quả mà lại xài trực tiếp Keys và Items và Transpose? Số lượng lớn Transpose không nổi đâu.
Option Explicit
Public Sub dem_trung()
Dim wb As Workbook, this_sheet As Worksheet, ws As Worksheet, r_ten As Range, rng As Range
Dim tam(), res_data(), i As Long, j As Long, c As Long, k As Long, r As Long, x As Long, ik As Long
Dim dic As New Scripting.Dictionary, sKey As String, shName As String
Set wb = ThisWorkbook
Set this_sheet = wb.ActiveSheet
Set rng = this_sheet.Range("A1")
this_sheet.Cells.ClearContents
j = wb.Worksheets.count
For Each ws In wb.Worksheets
If ws.Name <> this_sheet.Name Then
Set r_ten = ws.Range("B5")
r = ws.Range(r_ten, r_ten.End(xlDown)).Rows.count
res_data = r_ten.Resize(r): x = x + r
ReDim Preserve tam(1 To x)
For i = 1 To r
k = k + 1
tam(k) = res_data(i, 1) & "|" & ws.Name
Next i
ik = ik + 1
dic.Add ws.Name, ik
rng.Offset(, ik + 2).Value = "Sheet: " & ws.Name
End If
Next ws
k = 0: ReDim res_data(1 To x, 1 To j + 3)
For i = 1 To x
sKey = tam(i)
If i = 175 Then
Debug.Print i
End If
shName = Split_str(sKey, "|", 1)
sKey = Split_str(sKey, "|", 0)
If Not dic.Exists(sKey) Then
k = k + 1
dic.Add sKey, shName & "|" & k
res_data(k, 1) = k
res_data(k, 2) = sKey
res_data(k, 3) = 1
c = dic(shName)
res_data(k, c + 3) = 1
Else
ik = Split_str(dic(sKey), "|", 1)
c = dic(shName)
res_data(ik, c + 3) = res_data(ik, c + 3) + 1
res_data(ik, 3) = res_data(ik, 3) + 1
End If
Next i
rng.Value = "STT": rng.Offset(, 1) = "Ho ten": rng.Offset(, 2) = "So Lan trung"
rng.Offset(1).Resize(k, j + 3).Value = res_data
End Sub
Public Function Split_str(Str As String, s As String, n As Integer)
Dim tmp As Variant
If Len(Str) = 0 Then Exit Function
tmp = Split(Str, s)
Split_str = tmp(n)
End Function
Nếu lấy nhiều giá trị thì để trả về mảng giá trị cần lấy, nếu không phải gọi lại split() nhiều lần.
Có tiến bộ nhiều, cách dùng Dic linh hoạt, tuy nhiên thuật toán chưa hợp lý. Cố gắng viết lại chỉ 2 vòng For lồng nhau
Con cảm ơn Bác đã chỉ dẫn ạ, nhưng khi bỏ vòng lặp 'For i = 1 To x' con không có cách nào xác định được kích thước mảng res_data
Option Explicit
Public Function Split_str(Str As String, s As String, n As Integer)
Dim tmp As Variant
If Len(Str) = 0 Then Exit Function
tmp = Split(Str, s)
Split_str = tmp(n)
End Function
Public Sub dem_trung_2()
Dim data(), res_data(), dic As New Scripting.Dictionary, sKey As String
Dim i As Long, j As Long, c As Long, k As Long, r As Long, x As Long, ik As Long
Dim wb As Workbook, this_sheet As Worksheet, ws As Worksheet
Dim r_ten As Range, rng As Range, shName As String
Const tach As String = "|"
Set wb = ThisWorkbook: j = wb.Worksheets.Count
Set this_sheet = wb.ActiveSheet: Set rng = this_sheet.Range("A1")
x = 10000: ReDim res_data(1 To x, 1 To j + 3)
x = 2: this_sheet.Cells.ClearContents
For Each ws In wb.Worksheets
shName = ws.Name
If shName <> this_sheet.Name Then
Set r_ten = ws.Range("B5")
r = ws.Range(r_ten, r_ten.End(xlDown)).Rows.Count
data = r_ten.Resize(r)
x = x + 1
dic.Add shName, x
rng.Offset(, x).Value = "Sheet: " & shName
For i = 1 To r
sKey = data(i, 1)
If Not dic.Exists(sKey) Then
k = k + 1
dic.Add sKey, shName & tach & k
res_data(k, 1) = k
res_data(k, 2) = sKey
res_data(k, 3) = 1
res_data(k, x + 1) = 1
Else
sKey = dic(sKey)
ik = Split_str(sKey, tach, 1)
c = dic(shName) + 1
res_data(ik, c) = res_data(ik, c) + 1
res_data(ik, 3) = res_data(ik, 3) + 1
End If
Next i
End If
Next ws
If k = 0 Then Exit Sub
rng.Value = "STT": rng.Offset(, 1) = "Ho ten": rng.Offset(, 2) = "So Lan trung"
rng.Offset(1).Resize(k, j + 3).Value = res_data
End SubXin chảo @befaint , cảm ơn Bạn đã góp ý.
A! như vậy thì code trên của OT đã xử lý được rồi Bạn nhỉ?
ik = Split_str(sKey, tach, 1)Mỗi Sheet chỉ xét 1 lần nên "dic.Add shName, x" không cần thiết và "dic.Add sKey, shName & tach & k" với iTem "shName & tach & k" quá rối
Vâng Bác, con sẽ cố gắng thêm ạ.Mỗi Sheet chỉ xét 1 lần nên "dic.Add shName, x" không cần thiết và "dic.Add sKey, shName & tach & k" với iTem "shName & tach & k" quá rối
Chỉ cần: "dic.Add sKey, k" Và bỏ Public Function Split_str(Str As String, s As String, n As Integer)
x = 10000: ReDim res_data(1 To x, 1 To j + 3)
À, con nhầm vì quên không trừ 1 sheet kết quả,chính xác là j+2 ạ.
Option Explicit
Public Sub dem_trung_3()
Dim data(), res_data(), dic As New Scripting.Dictionary, sKey As String
Dim i As Long, j As Long, c As Long, k As Long, r As Long, x As Long, ik As Long
Dim wb As Workbook, this_sheet As Worksheet, ws As Worksheet
Dim r_ten As Range, rng As Range, shName As String
Const tach As String = "|"
Set wb = ThisWorkbook: j = wb.Worksheets.Count
Set this_sheet = wb.ActiveSheet: Set rng = this_sheet.Range("A1")
x = 10000: ReDim res_data(1 To x, 1 To j + 2)
x = 2: this_sheet.Cells.ClearContents
For Each ws In wb.Worksheets
shName = ws.Name
If shName <> this_sheet.Name Then
Set r_ten = ws.Range("B5")
r = ws.Range(r_ten, r_ten.End(xlDown)).Rows.Count
data = r_ten.Resize(r)
x = x + 1
dic.Add shName, x
rng.Offset(, x).Value = "Sheet: " & shName
For i = 1 To r
sKey = data(i, 1)
If Not dic.Exists(sKey) Then
k = k + 1
dic.Add sKey, k
res_data(k, 1) = k
res_data(k, 2) = sKey
res_data(k, 3) = 1
res_data(k, x + 1) = 1
Else
ik = dic(sKey)
c = dic(shName) + 1
res_data(ik, c) = res_data(ik, c) + 1
res_data(ik, 3) = res_data(ik, 3) + 1
End If
Next i
End If
Next ws
If k = 0 Then Exit Sub
rng.Value = "STT": rng.Offset(, 1) = "Ho ten": rng.Offset(, 2) = "So Lan trung"
rng.Offset(1).Resize(k, j + 2).Value = res_data
End SubOption Explicit
Public Sub loc_va_dem_trung()
Dim data(), res_data(), dic As New Scripting.Dictionary, sKey As String
Dim i As Long, j As Long, c As Long, k As Long, r As Long, x As Long, ik As Long
Dim wb As Workbook, this_sheet As Worksheet, ws As Worksheet
Dim r_ten As Range, rng As Range, shName As String
Const sh_line As String = "Line: "
Set wb = ThisWorkbook: j = wb.Worksheets.Count
Set this_sheet = wb.ActiveSheet: Set rng = this_sheet.Range("A1")
i = 2: this_sheet.Cells.ClearContents
For Each ws In wb.Worksheets
shName = ws.Name
If shName <> this_sheet.Name Then
Set r_ten = ws.Range("B5")
r = ws.Range(r_ten, r_ten.End(xlDown)).Rows.Count
x = x + r: i = i + 1
dic.Add shName, i
rng.Offset(, i).Value = sh_line & shName
End If
Next ws
ReDim res_data(1 To x, 1 To i + 1)
For Each ws In wb.Worksheets
shName = ws.Name
If dic.Exists(shName) Then
Set r_ten = ws.Range("B5")
r = ws.Range(r_ten, r_ten.End(xlDown)).Rows.Count
data = r_ten.Resize(r)
For i = 1 To r
sKey = data(i, 1)
If Not dic.Exists(sKey) Then
k = k + 1
dic.Add sKey, k
res_data(k, 1) = k
res_data(k, 2) = sKey
res_data(k, 3) = 1
ik = dic(shName) + 1
res_data(k, ik) = 1
Else
ik = dic(sKey)
c = dic(shName) + 1
res_data(ik, c) = res_data(ik, c) + 1
res_data(ik, 3) = res_data(ik, 3) + 1
End If
Next i
End If
Next ws
If k = 0 Then Exit Sub
rng.Value = "Stt": rng.Offset(, 1) = "Ho ten": rng.Offset(, 2) = "Tong cong"
rng.Offset(1).Resize(k, UBound(res_data, 2)).Value = res_data
End SubBạn tham khảo thêm
Sub XYZ()
Dim sArr(), resTD(), res(), Dic As New Scripting.Dictionary
Dim tKey$, shRes$
Dim shCount&, n&, jCol&, eRow&, sRow&, i&, k&, ik&
Dic.CompareMode = vbTextCompare
shRes = "Sheet1"
shCount = Worksheets.Count
ReDim res(1 To 10000, 1 To shCount + 2) 'Gioi han 10000 Lao Dong
ReDim resTD(1 To 1, 1 To shCount + 2) 'Dong Tieu de
resTD(1, 1) = "STT": resTD(1, 2) = "Ho ten": resTD(1, 3) = "So Lan trung"
jCol = 3 'Cot mang Ket qua
For n = 1 To shCount
If Sheets(n).Name <> shRes Then
eRow = Sheets(n).Range("C" & Rows.Count).End(xlUp).Row
If eRow >= 5 Then
jCol = jCol + 1
resTD(1, jCol) = "Sheet: " & Sheets(n).Name
sArr = Sheets(n).Range("B5:B" & eRow).Value
sRow = UBound(sArr)
For i = 1 To sRow
tKey = sArr(i, 1)
If tKey <> Empty Then
If Dic.Exists(tKey) = False Then
k = k + 1
Dic.Add tKey, k
res(k, 1) = k
res(k, 2) = tKey
End If
ik = Dic.Item(tKey)
res(ik, 3) = res(ik, 3) + 1
res(ik, jCol) = res(ik, jCol) + 1
End If
Next i
End If
End If
Next n
With Sheets(shRes)
.UsedRange.ClearContents
If k Then
.Range("A1").Resize(1, jCol) = resTD
.Range("A2").Resize(k, jCol) = res
End If
End With
End Sub
