Option Explicit
Sub TongHop()
Dim Sh As Worksheet
Dim Rws As Long, J As Long, W As Long, Col As Byte
With Sheets("TongHop")
Rws = .[B5].CurrentRegion.Rows.Count
.[B5].Resize(Rws, 9).ClearContents
W = 4
For Each Sh In ThisWorkbook.Worksheets
If Sh.Name <> "TongHop" Then
Col = Sh.UsedRange.Columns.Count + 2
For J = 3 To Sh.UsedRange.Rows.Count
If Sh.Cells(J, "A").End(xlToRight).Column < Col Then
W = W + 1
.Cells(W, "B").Value = Sh.Name
.Cells(W, "C").Resize(, Col).Value = Sh.Cells(J, "B").Resize(, Col).Value
End If
Next J
End If
Next Sh
End With
End Sub
Sub tonghop()
Dim ws As Worksheet
Dim arr(1 To 60000, 1 To 7) As Variant
Dim i, j, k As Long
Dim rng, v As Range
For Each ws In Worksheets
With ws
If ws.Name <> "TongHop" Then
On Error Resume Next
Set rng = .[b3:G60000].SpecialCells(2)
If Err Then GoTo next_step
On Error GoTo 0
rw = 0
For Each v In rng
If rw <> v.Row Then k = k + 1
arr(k, 1) = ws.Name
arr(k, v.Column) = v
rw = v.Row
Next
next_step:
End If
End With
Next
If k Then
With Sheets("TongHop")
.[b5:h6000].ClearContents
.[b5:h5].Resize(k) = arr
End With
End If
End Sub
Sub TongHop()
Dim Sh As Worksheet, ArrData, ArrResult(), i As Long, j As Long, k As Long, Check As Boolean
Me.Range("B5:H65536").ClearContents
ReDim ArrResult(0 To &H10000, 0 To 6)
For Each Sh In ThisWorkbook.Sheets
If Sh.Name <> Me.Name Then
ArrData = Sh.Range("B3:G25").Value
For i = 1 To UBound(ArrData, 1)
Check = False
For j = 1 To UBound(ArrData, 2)
If Not IsEmpty(ArrData(i, j)) Then
Check = True
ArrResult(k, j) = ArrData(i, j)
End If
Next
If Check Then
ArrResult(k, 0) = Sh.Name
k = k + 1
End If
Next
End If
Next
If k > 0 Then Me.Range("B5").Resize(k, 7).Value = ArrResult
End Sub1 cách nữa
Public Sub TongHop()
Dim Ws As Worksheet, Nguon As Range, Cll As Range, i, kq(1 To 65000, 1 To 7)
With CreateObject("scripting.dictionary")
For Each Ws In Worksheets
If Ws.Name <> "TongHop" Then
'Set Nguon = Ws.Range("B3", "G" & Ws.UsedRange.Rows.Count).SpecialCells(2)
'Sửa lại bên dưới
Set Nguon = Ws.Range("B3", "G" & Ws.UsedRange.Rows.Count + 2)
For Each Cll In Nguon
If Cll.Value <> "" Then
.Item(Ws.Name & Cll.Row) = ""
kq(.Count, 1) = Ws.Name
kq(.Count, Cll.Column) = Cll.Value
End If
Next Cll
End If
Next Ws
Sheet1.Range("J5", "P" & .Count + 4).ClearContents
Sheet1.Range("J5", "P" & .Count + 4) = kq
Sheet1.Range("J5", "P" & .Count + 4).Borders.LineStyle = 1
End With
End SubCode này sai gần giống bài #3 nhưng hậu quả sẽ nghiêm trọng hơn. Bạn thử test với trường hợp ở bài #4 sẽ thấy sai.
Sửa thế này thấy đúng, không biết vì sao
Set Nguon = Ws.Range("B3", "G" & Ws.UsedRange.Rows.Count).SpecialCells(2)
--->
Set Nguon = Ws.Range("B3", "G" & Ws.UsedRange.Rows.Count + 2).SpecialCells(2)Set Nguon = Ws.Range("B3", "G" & Ws.UsedRange.Rows.Count + 2)
vậy thử macro này xem có bị sai không
Sub Tonghop()
Dim sh As Worksheet, i As Long
Application.ScreenUpdating = False
Sheets("TongHop").Range("5:10000").Clear
For Each sh In Worksheets
If sh.Name <> "TongHop" Then
sh.Range("A3:A" & sh.UsedRange.Rows.Count).Value = sh.Name
sh.[A3].CurrentRegion.Offset(1).Copy
Sheets("TongHop").Range("B10000").End(3).Offset(1).PasteSpecial (12)
sh.Range("A:A").Clear
End If
Next
For i = 1 To 6
Sheets("TongHop").Range("O1").Offset(i, i - 1).Value = "<>"
Next
With Sheets("TongHop")
.Range("O1:T1").Value = Range("C4:H4").Value
.Range("B4:H10000").AdvancedFilter 2, Range("O1:T7"), Range("AA5"), False
.Range("B4:H10000").Value = Range("AA5:AG10000").Value
.Range("N:AG").Clear
.Range("B4").CurrentRegion.Borders.LineStyle = 1
.Range("B4").Select
End With
Application.ScreenUpdating = True
End SubEm cũng bon chen cùng bác SA_DQ. Nhờ 2 cuốn sách của bác mà cũng biết ghi macro
Sub Tonghop2()
Dim Sh As Worksheet, T As Double, I As Integer
Dim Crits As Range, Dest As Range, Data As Range
T = Timer
Application.ScreenUpdating = False
Sheet1.Range("C4", Range("C4").End(2)).Copy: Range("O1").PasteSpecial (12)
For I = 1 To Sheet1.Range("O1").CurrentRegion.Columns.Count
Sheet1.Range("O1").Offset(I, I - 1).Value = "<>"
Next
Sheet1.Range("A5:K10000").Clear
For Each Sh In Worksheets
If Sh.Name <> "TongHop" Then
Sh.Range("A3:A" & Sh.UsedRange.Rows.Count + 10).Value = Sh.Name
Sh.Range("A2") = "Sheet"
Set Data = Sh.Range("A2").CurrentRegion
Set Crits = Sheet1.Range("O1").CurrentRegion
Set Dest = Sheet1.Range("B10000").End(3).Offset(1)
Data.AdvancedFilter 2, Crits, Dest, False
Sh.Range("A:A").Clear
End If
Next
With Sheet1
.Range("N:AG").Clear
.Range("B4").CurrentRegion.Borders.LineStyle = 1
.Range("B4").CurrentRegion.AutoFilter 1, "Sheet"
.Range("B4").CurrentRegion.Offset(1).Delete Shift:=xlUp
.Range("B4").CurrentRegion.AutoFilter
.Range("B4").Select
End With
Application.ScreenUpdating = True
[A1] = Timer - T
End Sub
Thế viết code kiểu thành phổ ở trên bạn không hiểu à? Tôi thấy code trên viết nó dài thôi chứ có câu lệnh nào phức tạp đâu.Xin chào hpkhuong,
nếu có thể bạn có thể giải thích giúp code trên theo cách gọi "kiểu nông dân" này được không?
https://www.giaiphapexcel.com/diendan/threads/lọc-và-đưa-dữ-liệu-mới-ra-1-wordbook-riêng.138155/#post-884863
Cảm ơn bạn nhiều
Thử với code
Sub GPE()
Dim Res(), DuLieu(), TongHop()
Dim khStr As String, iKey As String
Dim i As Long, ik As Long, j As Long, sCol As Long, jCol As Long
Dim Ngay As Date
With Sheets("DU_LIEU")
i = .Range("E1000000").End(xlUp).Row
DuLieu = .Range("E6:BA" & i).Value
Ngay = .Range("D2").Value
End With
With Sheets("TONG_HOP")
i = .Range("B8").End(xlDown).Row
sCol = .Range("AAA8").End(xlToLeft).Column
On Error Resume Next
jCol = Application.Match(Ngay, .Range("A8").Resize(, sCol).Value, 0)
On Error GoTo 0
TongHop = .Range("A8:A" & i).Resize(, sCol).Value
.Range("A9:A" & i).Resize(, sCol).ClearContents
End With
With Sheets("DMSP")
i = .Range("B8").End(xlDown).Row
Res = .Range("A9:A" & i).Resize(, sCol).Value
End With
With CreateObject("scripting.dictionary")
For i = 2 To UBound(Res) - 1
If Len(Res(i, 3)) > 0 Then
If Len(Res(i - 1, 3)) = 0 Then khStr = Res(i - 1, 2)
.Item(khStr & "#" & Res(i, 4)) = i
End If
Next i
For i = 2 To UBound(TongHop) - 1
If Len(TongHop(i, 3)) > 0 Then
If Len(TongHop(i - 1, 3)) = 0 Then khStr = TongHop(i - 1, 2)
ik = .Item(khStr & "#" & TongHop(i, 4))
If ik Then
For j = 12 To sCol
If Len(TongHop(i, j)) Then Res(ik, j) = TongHop(i, j)
Next j
End If
End If
Next i
If jCol Then
For i = 1 To UBound(DuLieu) Step 8
ik = .Item(DuLieu(i, 1) & "#" & DuLieu(i, 2))
If ik Then Res(ik, jCol) = DuLieu(i, 49)
Next i
End If
End With
Sheets("TONG_HOP").Range("A9").Resize(UBound(Res), UBound(Res, 2)) = Res
End SubGiá trị trong cột màu vàng sheet "TONG HOP" không đổi hay hay bê từ sheet "DMSP" qua
