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
Xin chào HieuCD,
Chỉnh lại cột
Sub GPE_2()
' HieuCD
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, 4)) > 0 Then 'Chinh so 4
If Len(Res(i - 1, 4)) = 0 Then khStr = Res(i - 1, 2) 'Chinh so 4
.Item(khStr & "#" & Res(i, 5)) = i 'Chinh so 5
End If
Next i
For i = 2 To UBound(TongHop) - 1
If Len(TongHop(i, 4)) > 0 Then 'Chinh so 4
If Len(TongHop(i - 1, 4)) = 0 Then khStr = TongHop(i - 1, 2) 'Chinh so 4
ik = .Item(khStr & "#" & TongHop(i, 5)) 'Chinh so 5
If ik Then
For j = 13 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 Sub
Thử chỉnh code trong bài của anh @HieuCD
Dim i As Long, ik As Long, j As Long, sCol As Long, jCol As Long
Dim Ngay As Date
DuLieu = .Range("E6:BA" & i).Value
Ngay = .Range("D2").ValueDim i As Long, ik As Long, j As Long, sCol As Long, jCol As Variant
Dim Ngay as Long
DuLieu = .Range("E6:BA" & i).Value2
Ngay = .Range("D2").Value2On Error Resume Next
jCol = Application.Match(Ngay, .Range("A8").Resize(, sCol).Value, 0)
On Error GoTo 0jCol = Application.Match(Ngay, .Range("A8").Resize(, sCol).Value2, 0)
If TypeName(jCol) = "Error" Then jCol = 0If jCol ThenIf jCol>0 ThenKhông rỏ nhập liệu như thế nào, nên chỉ điều chỉnh khai báo
Không rỏ đặc điểm tạo mã hàng, nên ghép Khách hàng và mã hàng làm key của Dic
Sub GPE_3()
Dim Res(), DuLieuKey(), DuLieuSum(), 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
DuLieuKey = .Range("E6:F" & i).Value
DuLieuSum = .Range("BG6:BK" & 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:G" & i).Value
ReDim Preserve Res(1 To UBound(Res), 1 To sCol)
End With
With CreateObject("scripting.dictionary")
For i = 2 To UBound(Res) - 1
If Len(Res(i, 5)) > 0 Then
If Len(Res(i - 1, 5)) = 0 Then khStr = Res(i - 1, 2)
.Item(khStr & "#" & Res(i, 5)) = i
End If
Next i
For i = 2 To UBound(TongHop) - 1
If Len(TongHop(i, 5)) > 0 Then
If Len(TongHop(i - 1, 5)) = 0 Then khStr = TongHop(i - 1, 2)
ik = .Item(khStr & "#" & TongHop(i, 5))
If ik > 0 Then
For j = 13 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(DuLieuKey) Step 8
ik = .Item(DuLieuKey(i, 1) & "#" & DuLieuKey(i, 2))
If ik > 0 Then Res(ik, jCol) = DuLieuSum(i, 1) + DuLieuSum(i, 4) + DuLieuSum(i, 5)
Next i
End If
End With
Sheets("TONG_HOP").Range("A9").Resize(UBound(Res), UBound(Res, 2)) = Res
End Sub@HieuCD
Thêm bẩy lỗi
Sub GPE_3()
Dim Res(), DuLieuKey As Variant, DuLieuSum(), TongHop As Variant
Dim iKey As String
Dim i As Long, ik As Long, j As Long, sCol As Long, jCol As Long
Dim Ngay
With Sheets("TONG_HOP")
sCol = .Range("AAA8").End(xlToLeft).Column
On Error Resume Next
jCol = Application.Match(Ngay, .Range("A8").Resize(, sCol).Value, 0)
On Error GoTo 0
i = .Range("B8").End(xlDown).Row
If i < Rows.Count Then
TongHop = .Range("A8:A" & i).Resize(, sCol).Value
.Range("A9:A" & i).Resize(, sCol).ClearContents
End If
End With
With Sheets("DMSP")
i = .Range("B" & Rows.Count).End(xlUp).Row
If i < 9 Then MsgBox ("Khong co du lieu"): Exit Sub
Res = .Range("A9:G" & i).Value
ReDim Preserve Res(1 To UBound(Res), 1 To sCol)
End With
With Sheets("DU_LIEU")
i = .Range("F1000000").End(xlUp).Row
If i > 5 Then
DuLieuKey = .Range("F6:F" & i).Value
DuLieuSum = .Range("BG6:BK" & i).Value
Ngay = .Range("D2").Value
End If
End With
With CreateObject("scripting.dictionary")
For i = 2 To UBound(Res) - 1
iKey = Res(i, 5)
If Len(iKey) > 0 Then .Item(iKey) = i
Next i
If TypeName(TongHop) = "Variant()" Then
For i = 2 To UBound(TongHop) - 1
iKey = TongHop(i, 5)
If Len(iKey) > 0 Then
ik = .Item(iKey)
If ik > 0 Then
For j = 13 To sCol
If Len(TongHop(i, j)) Then Res(ik, j) = TongHop(i, j)
Next j
End If
End If
Next i
End If
If jCol And TypeName(DuLieuKey) = "Variant()" Then
For i = 1 To UBound(DuLieuKey) Step 8
ik = .Item(DuLieuKey(i, 1))
If ik > 0 Then Res(ik, jCol) = DuLieuSum(i, 1) + DuLieuSum(i, 4) + DuLieuSum(i, 5)
Next i
End If
End With
Sheets("TONG_HOP").Range("A9").Resize(UBound(Res), UBound(Res, 2)) = Res
End Sub
Bạn chạy thử Sub "Cùi Bắp" này xem sao.
Public Sub LuXuBu()
Const Col As Long = 12
Dim Dic As Object, Txt As String
Dim sArr(), tArr(), dArr()
Dim I As Long, J As Long, K As Long, N As Long, R As Long, R2 As Long, Thang As Long
Set Dic = CreateObject("Scripting.Dictionary")
Thang = Month(Sheets("DU_LIEU").Range("D2"))
With Sheets("DMSP")
sArr = .Range("A9", .Range("B9").End(xlDown)).Resize(, 7).Value
R = UBound(sArr)
ReDim dArr(1 To R, 1 To Thang + Col)
For I = 1 To R
Txt = sArr(I, 5)
If Len(Txt) Then Dic.Item(Txt) = I
For J = 1 To 7
dArr(I, J) = sArr(I, J)
Next J
Next I
End With
With Sheets("DU_LIEU")
sArr = .Range("F6", .Range("F100000").End(xlUp)).Resize(, 58).Value
R2 = UBound(sArr)
For I = 1 To R2 Step 8
Txt = sArr(I, 1)
If Dic.Exists(Txt) Then
N = Dic.Item(Txt)
dArr(N, Thang + Col) = sArr(I, 54) + sArr(I, 57) + sArr(I, 58)
End If
Next I
End With
With Sheets("TONG_HOP")
sArr = .Range("A9", .Range("B9").End(xlDown)).Resize(, Thang + Col - 1).Value
R2 = UBound(sArr)
For I = 2 To R2
Txt = sArr(I, 5)
If Dic.Exists(Txt) Then
N = Dic.Item(Txt)
For J = 1 To Thang - 1
dArr(N, J + Col) = sArr(I, J + Col)
Next J
End If
Next I
.Range("A9").Resize(1000, 24).ClearContents
.Range("A9").Resize(R, Thang + Col) = dArr
End With
Set Dic = Nothing
End SubChỉnh lại
Sub GPE_3()
Dim Res As Variant, DuLieuKey As Variant, DuLieuSum As Variant, TongHop As Variant
Dim iKey As String
Dim i As Long, ik As Long, j As Long, sCol As Long, jCol As Long
Dim Ngay
With Sheets("DU_LIEU")
i = .Range("F1000000").End(xlUp).Row
If i > 5 Then
DuLieuKey = .Range("F6:F" & i).Value
DuLieuSum = .Range("BG6:BK" & i).Value
Ngay = .Range("D2").Value
End If
End With
With Sheets("TONG_HOP")
sCol = .Range("AAA8").End(xlToLeft).Column
On Error Resume Next
jCol = Application.Match(Ngay, .Range("A8").Resize(, sCol).Value, 0)
On Error GoTo 0
i = .Range("B8").End(xlDown).Row
If i < Rows.Count Then
TongHop = .Range("A8:A" & i).Resize(, sCol).Value
.Range("A9:A" & i).Resize(, sCol).ClearContents
End If
End With
With Sheets("DMSP")
i = .Range("B" & Rows.Count).End(xlUp).Row
If i < 9 Then MsgBox ("Khong co du lieu"): Exit Sub
Res = .Range("A9:G" & i).Value
ReDim Preserve Res(1 To UBound(Res), 1 To sCol)
End With
With CreateObject("scripting.dictionary")
For i = 2 To UBound(Res) - 1
iKey = CStr(Res(i, 5))
If Len(iKey) > 0 Then .Item(iKey) = i
Next i
If TypeName(TongHop) = "Variant()" Then
For i = 2 To UBound(TongHop) - 1
iKey = CStr(TongHop(i, 5))
If Len(iKey) > 0 Then
ik = .Item(iKey)
If ik > 0 Then
For j = 13 To sCol
If Len(TongHop(i, j)) Then Res(ik, j) = TongHop(i, j)
Next j
End If
End If
Next i
End If
If jCol And TypeName(DuLieuKey) = "Variant()" Then
For i = 1 To UBound(DuLieuKey) Step 8
ik = .Item(CStr(DuLieuKey(i, 1)))
If ik > 0 Then Res(ik, jCol) = DuLieuSum(i, 1) + DuLieuSum(i, 4) + DuLieuSum(i, 5)
Next i
End If
End With
Sheets("TONG_HOP").Range("A9").Resize(UBound(Res), UBound(Res, 2)) = Res
End Sub
Xin chào Miền Cát Trắng
Dạ, code của Thầy đúng ý Oanh Thơ rồi ạ.
Cảm ơn tam888 đã quan tâm,
