thầy ơi khóa học này ko hướng dẫn lọc dữ liệu ra thành nhiều file ạ,
Chào bạn vào lại nhé.
minh muốn kết quả dữ nguyên form của file ban đầu là vẫn giữ dòng bảng dữ liệu đào tạo, mình đang thây file tach ra bị mất dòng tiêu đề đàu tiên bảng dữ liệu đào tạo
Bạn thực hiện code như sau nhé:
Sub tachfile_nhieufile()
Sheet1.Activate
With Sheet1
Dim dc As Long, ws As Worksheet, rng As Range, cell As Range, dcloc As Long, arr As Variant
dc = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("J3:J" & dc).ClearContents
arr = Unique2DArray(.Range("E3:E" & dc).Value, 1, False)
.Range("J3").Resize(UBound(arr), 1).Value = arr
dcloc = .Range("J" & .Rows.Count).End(xlUp).Row
Set rng = Range("A2:I" & dc)
For Each cell In .Range("J3:J" & dcloc)
Set ws = Worksheets.Add(after:=Sheets(Sheets.Count))
rng.AutoFilter field:=5, Criteria1:=cell.Value
rng.SpecialCells(xlCellTypeVisible).Copy ws.Cells(2, 1)
ws.Name = cell.Value
ws.UsedRange.EntireColumn.AutoFit
'' ban tu dinh dang
ws.Range("A1").Value = .Range("A1").Value
ws.Range("A1").Font.Bold = True
ws.Range("A1").Font.Size = 24
Next
rng.AutoFilter
.Range("J3:J" & dc).ClearContents
End With
Set ws = Nothing: Set rng = Nothing: Set cell = Nothing
End Sub
hoặc bạn có thể tự xây dựng
mình cảm ơn ạ
Chào bạn bạn thử nhé:
Sub tachfile_nhieufile()
Sheet1.Activate
With Sheet1
Dim dc As Long, ws As Worksheet, rng As Range, cell As Range, dcloc As Long, arr As Variant
dc = .Range("A" & .Rows.Count).End(xlUp).Row
'.Range("D8:D" & dc).ClearContents
arr = Unique2DArray(.Range("D8:D" & dc).Value, 1, False)
.Range("S3").Resize(UBound(arr), 1).Value = arr
dcloc = .Range("S" & .Rows.Count).End(xlUp).Row
Set rng = Range("A8:Q" & dc)
For Each cell In .Range("D8:D" & dcloc)
Set ws = Worksheets.Add(after:=Sheets(Sheets.Count))
rng.AutoFilter field:=4, Criteria1:=cell.Value
rng.SpecialCells(xlCellTypeVisible).Copy ws.Cells(1, 1)
ws.UsedRange.EntireColumn.AutoFit
Next
rng.AutoFilter
.Range("R3:R" & dc).ClearContents
End With
Set ws = Nothing: Set rng = Nothing: Set cell = Nothing
End Sub
'Tac gia: NDU
'Website:Giaiphapexcel
'****************************************
Function Unique2DArray(ByVal sArray, ByVal ColIndex As Long, ByVal HasTitle As Boolean) ' vungdulieu, cot loc, dung hoac sai
Dim tmpArr, KeyArr, tmp, i As Long, j As Long, arr
On Error Resume Next
tmpArr = sArray
ColIndex = ColIndex + LBound(tmpArr, 2) - 1
With CreateObject("Scripting.Dictionary")
For i = LBound(tmpArr, 1) - HasTitle To UBound(tmpArr, 1)
tmp = tmpArr(i, ColIndex)
If Not .Exists(tmp) And tmp <> "" Then .Add tmp, i
Next
If .Count Then
KeyArr = .Keys
ReDim arr(LBound(KeyArr) + LBound(tmpArr, 1) To UBound(KeyArr) - HasTitle + LBound(tmpArr, 1), LBound(tmpArr, 2) To UBound(tmpArr, 2))
For i = LBound(KeyArr) To UBound(KeyArr)
For j = LBound(tmpArr, 2) To UBound(tmpArr, 2)
arr(i - HasTitle + LBound(tmpArr, 1), j) = tmpArr(.Item(KeyArr(i)), j)
Next
Next
If HasTitle Then
For j = LBound(tmpArr, 2) To UBound(tmpArr, 2)
arr(LBound(tmpArr, 1), j) = tmpArr(LBound(tmpArr, 1), j)
Next
End If
Unique2DArray = arr
End If
End With
End Function
Sub GTH_onAction(control As IRibbonControl)
On Error GoTo THOAT
ThisWorkbook.FollowHyperlink Address:="https://gitiho.com/", NewWindow:=True
THOAT: Exit Sub
End Sub
Sub Callback(control As IRibbonControl)
Call tachfile_nhieufile
MsgBox "Thành công"
End Sub