Má ơi, sao có kiểu lọc gì oái oăm thế này
Mình khoái mấy bài thế này, chơi đường tà đạo vầy xem sao. Xử lý bằng code hết, không tạo thêm name nào cả
Sub tong()
Dim d As Object, dl(), sh As Worksheet, tong
Dim i As Long, FR As Long, FC As Long, LC As Long, dk1 As String, dk2 As String, n As Long
Set d = CreateObject("scripting.dictionary")
Set tong = Sheets("Tong")
dk1 = tong.[b5]: dk2 = tong.[c5]
For Each sh In Worksheets
If sh.Name <> "Tong" Then
With sh.UsedRange
FR = .Find(dk1).Offset(1).Row
FC = .Find(dk1).Column
LC = .Find(dk2).Column
End With
dl = sh.Range(sh.Cells(FR, FC), sh.Cells(65536, LC).End(3)).Value
n = UBound(dl, 2)
For i = 1 To UBound(dl)
If dl(i, n) > 0 Then
If Not d.exists(dl(i, 1)) Then
d.Add dl(i, 1), dl(i, n)
Else
d.Item(dl(i, 1)) = d.Item(dl(i, 1)) + dl(i, n)
End If
End If
Next
End If
Next
tong.[b6:c10000].ClearContents
tong.[b6].Resize(d.Count) = Application.Transpose(d.keys)
tong.[C6].Resize(d.Count) = Application.Transpose(d.items)
End Sub
Nếu có thêm vài sheet chẳng có dữ liệu gì cả thì sao nhỉ? Tôi thử thì bị lỗi mấy cái Find().
Tham gia "Quánh võ mèo" một cái xem.
Public Sub GPE()
Dim Ws As Worksheet, Rng(), i As Long, n As Long, Dic As Object, K As Long, Arr(), Tem As Variant, SL As Double
Set Dic = CreateObject("Scripting.Dictionary")
ReDim Arr(1 To 65000, 1 To 2)
For Each Ws In Worksheets
If Ws.Name Like "Dulieu*" Then
If Ws.UsedRange.Rows.Count > 1 Then
Rng = Ws.UsedRange.Value
n = UBound(Rng, 2)
For i = 2 To UBound(Rng, 1)
Tem = Rng(i, 1): SL = Rng(i, n)
If SL > 0 Then
If Not Dic.exists(Tem) Then
K = K + 1
Dic.Add Tem, K
Arr(K, 1) = Tem: Arr(K, 2) = Rng(i, n)
Else
Arr(Dic.Item(Tem), 2) = Arr(Dic.Item(Tem), 2) + Rng(i, n)
End If
End If
Next i
End If
End If
Next
Sheet1.[E6:F1000].ClearContents
Sheet1.[E6].Resize(K, 2).Value = Arr
Set Dic = Nothing
End SubNếu vậy thì em phải thêm 1 cái bẫy lỗi rồi
Sub tong()
Dim d As Object, dl(), sh As Worksheet, tong
Dim i As Long, FR As Long, FC As Long, LC As Long, dk1 As String, dk2 As String, n As Long
Set d = CreateObject("scripting.dictionary")
Set tong = Sheets("Tong")
dk1 = tong.[b5]: dk2 = tong.[c5]
For Each sh In Worksheets
If sh.Name <> "Tong" Then
If sh.UsedRange.Count > 1 Then
With sh.UsedRange
FR = .Find(dk1).Offset(1).Row
FC = .Find(dk1).Column
LC = .Find(dk2).Column
End With
dl = sh.Range(sh.Cells(FR, FC), sh.Cells(65536, LC).End(3)).Value
n = UBound(dl, 2)
For i = 1 To UBound(dl)
If dl(i, n) > 0 Then
If Not d.exists(dl(i, 1)) Then
d.Add dl(i, 1), dl(i, n)
Else
d.Item(dl(i, 1)) = d.Item(dl(i, 1)) + dl(i, n)
End If
End If
Next
End If
End If
Next
tong.[b6:c10000].ClearContents
tong.[b6].Resize(d.Count) = Application.Transpose(d.keys)
tong.[C6].Resize(d.Count) = Application.Transpose(d.items)
End SubCám ơn bác Lợi nhiều, mà bác thèm "b" là thèm gì nhỉ?
Tà đạo hay chính đạo mà đi đến được mục tiêu tốt thì nên đi phải không anh? Cám ơn anh nhiều !
Cám ơn bác Ba Te, bước đầu em tìm hiểu code, mong bác chia sẻ vài chiêu võ "Tiểu hổ" của bác với !
Pivot nhiều vùng được không thầy? Em chỉ biết sử dụng Pivot trên 1 bảng dữ liệu thôi
Sub TongHop_HLMT()
Set adoConn = New ADODB.Connection
Set adoRS = New ADODB.Recordset
With adoConn
.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & ThisWorkbook.FullName & _
";Extended Properties=""Excel 8.0;HDR=No;"";"
.Open
End With
With adoRS
.ActiveConnection = adoConn
.Open "select F1, sum(F3) from " & _
"(SELECT F1, F3 FROM Name1 " & _
"Union ALL " & _
"SELECT F1, F6 FROM Name2 " & _
"Union ALL " & _
"SELECT F1, F6 FROM Name3) " & _
"group by F1 " & _
"having sum(F3)>0"
End With
[B6].CopyFromRecordset adoRS
adoRS.Close: Set adoRS = Nothing
adoConn.Close: Set adoConn = Nothing
End Sub
