Đỗ Thị Sơn Thủy
Đỗ Thị Sơn Thủy
Thảo luận 13 thảo luận
Vỗ tay 0 vỗ tay
Lượt xem 370 lượt xem

khóa học này ko hướng dẫn lọc dữ liệu ra thành nhiều file ạ

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 ạ, 

Thảo luận 13 câu trả lời
Lượt xem 370 lượt xem
Vỗ tay vỗ tay
Đỗ Thị Sơn Thủy 17:10 - Oct 07, 2020

Chào bạn bạn xem file này nhé:

https://drive.google.com/file/d/170sZ...

pass gitiho

Vỗ tay vỗ tay
Đỗ Thị Sơn Thủy 10:10 - Oct 09, 2020


Vỗ tay vỗ tay
Đỗ Thị Sơn Thủy 10:10 - Oct 09, 2020
mình không mở được file ạ
Vỗ tay vỗ tay
Đỗ Thị Sơn Thủy 10:10 - Oct 09, 2020

Chào bạn vào lại nhé.

Vỗ tay vỗ tay
Đỗ Thị Sơn Thủy 11:10 - Oct 09, 2020

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

Vỗ tay vỗ tay
Đỗ Thị Sơn Thủy 12:10 - Oct 09, 2020

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

Vỗ tay vỗ tay
Đỗ Thị Sơn Thủy 12:10 - Oct 09, 2020

hoặc bạn có thể tự xây dựng

Vỗ tay vỗ tay
Đỗ Thị Sơn Thủy 13:10 - Oct 09, 2020

mình cảm ơn ạ

Vỗ tay vỗ tay
Đỗ Thị Sơn Thủy 14:10 - Oct 09, 2020


Vỗ tay vỗ tay
Đỗ Thị Sơn Thủy 14:10 - Oct 09, 2020


Vỗ tay vỗ tay
Đỗ Thị Sơn Thủy 14:10 - Oct 09, 2020


Vỗ tay vỗ tay
Đỗ Thị Sơn Thủy 14:10 - Oct 09, 2020
đấy là code e viết ạ nhưng tao ra file mơi snhuwng ko coppy dữ liệu sang đc ạ :( lỗi báo như ảnh trên ạ a xem giúp e vs
Vỗ tay vỗ tay
Đỗ Thị Sơn Thủy 15:10 - Oct 09, 2020

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

Vỗ tay vỗ tay
Câu hỏi liên quan
© 2020 - Bản quyền của Công Ty Cổ Phần Công Nghệ Giáo Dục Gitiho Việt Nam
Giấy chứng nhận Đăng ký doanh nghiệp số: 0109077145, cấp bởi Sở Kế hoạch và Đầu tư TP. Hà Nội
Giấy phép mạng xã hội số: 588, cấp bởi Bộ Thông tin và Truyền thông