Dữ liệu đưa lên nhờ làm phải như bạn thì người giúp như tôi mới thấy hứng thú để làm. Dữ liệu chuẩn, dư đủ để test.
Thử code này
Option Explicit
Sub abc()
Dim ws As Worksheet, iR&
For Each ws In Worksheets
iR = Sheets("tong hop").Range("E" & Rows.Count).End(3).Row + 1
If ws.Name Like "C*" Then
ws.Range("A6:A" & ws.Range("E5").End(4).Row).Resize(, 9).Copy Sheets("tong hop").Range("A" & iR)
End If
Next
End Sub
1/ Cái này theo tôi thì nên để dữ liệu các lớp trong 1 sheet tong hop, muốn tách các lớp ra thì dựa vào cột D thì sẽ thuận tiện hơn là bạn theo dõi mỗi lớp 1 sheet rồi gộp lại, bạn có thể theo dõi tất cả các lớp khác nữa. Không lẽ mỗi nhóm lớp bạn lại theo dõi 1 File.
Bạn thử:
Sub Test()
Dim ws, sh As Worksheet, LR As Long
Set sh = Worksheets("tong hop")
For Each ws In Worksheets
LR = sh.Cells(Rows.Count, 1).End(xlUp).Row
If ws.Name <> "tong hop" Then
ws.Activate
ws.Range("a6:i52").Copy
sh.Cells(LR, 1).Offset(1).PasteSpecial Paste:=xlPasteValues
End If
Next
Application.CutCopyMode = False
Worksheets("tong hop").Activate
End SubVậy cũng hay. Nhờ be_09 giúp nhé. Cảm ơn
Bạn vào sheet Trang chủ nhấn theo tên nút để nhận kết quả.
Sub CombineData()
Dim cnn As Object, Rst As Object
Dim strQuery As String
Dim Ws As Worksheet, FirstWs As Boolean, Header As Range
FirstWs = True
For Each Ws In ThisWorkbook.Sheets
If Ws.Name Like "C*" Then
If FirstWs Then
Set Header = Ws.Range("A1:I5")
strQuery = _
"SELECT " & _
" * " & _
"FROM " & _
" [" & Ws.Name & "$A6:I100] " & _
"WHERE " & _
" F6 IS NOT NULL "
Else
strQuery = strQuery & _
"UNION ALL " & _
"SELECT " & _
" * " & _
"FROM " & _
" [" & Ws.Name & "$A6:I100] " & _
"WHERE " & _
" F6 IS NOT NULL "
End If
FirstWs = False
End If
Next Ws
Set cnn = CreateObject("ADODB.Connection")
Set Rst = CreateObject("ADODB.Recordset")
With cnn
.connectionstring = "Provider=Microsoft.ACE.OLEDB.12.0" & _
";Data Source=" & ThisWorkbook.FullName & _
";Extended Properties='Excel 12.0 Xml;HDR=No';"
.Open
End With
Set Rst = cnn.Execute(strQuery)
Sheet16.UsedRange.Clear
With Sheet16.Range("A6")
.CopyFromRecordset Rst
.CurrentRegion.Borders.LineStyle = 1
.CurrentRegion.Borders(xlInsideHorizontal).Weight = xlHairline
.CurrentRegion.Offset(, 4).Resize(, 2).Borders(xlInsideVertical).LineStyle = 0
End With
Header.Copy Sheet16.Range("A1")
Sheet16.Range("A6").CurrentRegion.EntireColumn.AutoFit
cnn.Close
Set cnn = Nothing: Set Rst = Nothing: Set Header = Nothing
End Sub
