Lọc và đưa dữ liệu mới ra 1 wordbook riêng

[thaytutn]

Các bác, các thầy ơi giúp em với, em có dữ liệu như vậy, giờ có cách nào dùng vba tạo 1 nút thực hiện công việc:
Tạo 1 workbook mới với các sheets trong đó, mỗi sheet sẽ có tên chính là mã hàng và dữ liệu của mối sheet sẽ là nội dung trong file demo kia tương ứng với từng mã đó. GIúp em với ạ, thanks các bác và các thầy ạ

 

[giaiphap]

Các bác, các thầy ơi giúp em với, em có dữ liệu như vậy, giờ có cách nào dùng vba tạo 1 nút thực hiện công việc:
Tạo 1 workbook mới với các sheets trong đó, mỗi sheet sẽ có tên chính là mã hàng và dữ liệu của mối sheet sẽ là nội dung trong file demo kia tương ứng với từng mã đó. GIúp em với ạ, Cảm ơn các bác và các thầy ạ

Bạn tự kiểm tra xem đúng yêu cầu chưa?

 

[thaytutn]

Bạn tự kiểm tra xem đúng yêu cầu chưa?

Thanhks thầy ạ!

 

[thaytutn]

Bạn tự kiểm tra xem đúng yêu cầu chưa?

thầy có thể chú thích ý nghĩa trên code để em học tập dc ko ah, chứ em xem mông lung quá!

 

[giaiphap]

thầy có thể chú thích ý nghĩa trên code để em học tập dc ko ah, chứ em xem mông lung quá!

Tôi giải thích theo kiểu nông dân nhé.

Public Sub GPE()
Dim Dic As Object, sArr(), Ws As Worksheet, i As Integer, Rng As Range   'Khai báo các biến cần thiết
    sArr() = Sheet1.Range("A2:A" & Sheet1.Range("A65000").End(xlUp).Row).Value     'Lấy danh sách các mã trong dữ liệu
   Set Dic = CreateObject("Scripting.Dictionary")        'Khai báo danh sách
    Application.ScreenUpdating = False   'Tắt cập nhật màn hình
    With Sheet1     
        .Range("K1").Value = .Range("A1").Value  'Đặt giá trị ô K1 bằng ô A1, đây là cột điều kiện lọc
        For i = 1 To UBound(sArr, 1)   'Duyệt qua tất cả các mã dữ liệu đã đưa vào mảng sArr
            If Not Dic.exists(sArr(i, 1)) Then  'Nếu mã này chưa lọc, tức chưa có trong danh sách Dic
                Dic.Add sArr(i, 1), ""   'Thêm mã này vào danh sách Dic
                .Range("K2").Value = sArr(i, 1)  'Đặt giá trị ô K2 bằng mã chưa lọc này sArr(i,1)
                Set Ws = Worksheets.Add(, Sheet1)  'Thêm sheet mới phía sau sheet1
                Ws.Name = sArr(i, 1) 'Đặt tên sheet mới này là mã mới thêm sArr(i,1)
                .Range("A1:G28").AdvancedFilter Action:=xlFilterCopy, _
                CriteriaRange:=.Range("K1:K2"), CopyToRange:=Ws.Range("A1:G1"), Unique:=False  'Lọc danh sách dữ liệu có mã mới sArr(i,1) sang sheet mới .
                Set Rng = Ws.Range("A65000").End(xlUp)   'Đặt vùng Rng là ô cuối cùng trong cột A của sheet mới
            End If
        Next i                                                                  
        .Range("K1:K2").ClearContents   'Xóa giá trị 2 ô K1 và K2 trong sheet1 (2 Ô này là 2 ô tạm để đặt điều kiện lọc)
    End With
    Sheets(Dic.Keys).Move   'Chọn tất cả các sheet mới thêm vào và di chuyển sang file mới
    Set Dic = Nothing   'Giải phóng bộ nhớ cho danh sách Dic
    Application.ScreenUpdating = True   'Mở cập nhật màn hình
    MsgBox "Da tach xong"   'Thông báo đã thực hiện xong
End Sub

 

[thaytutn]

Tôi giải thích theo kiểu nông dân nhé.

Public Sub GPE()
Dim Dic As Object, sArr(), Ws As Worksheet, i As Integer, Rng As Range   'Khai báo các biến cần thiết
    sArr() = Sheet1.Range("A2:A" & Sheet1.Range("A65000").End(xlUp).Row).Value     'Lấy danh sách các mã trong dữ liệu
   Set Dic = CreateObject("Scripting.Dictionary")        'Khai báo danh sách
    Application.ScreenUpdating = False   'Tắt cập nhật màn hình
    With Sheet1    
        .Range("K1").Value = .Range("A1").Value  'Đặt giá trị ô K1 bằng ô A1, đây là cột điều kiện lọc
        For i = 1 To UBound(sArr, 1)   'Duyệt qua tất cả các mã dữ liệu đã đưa vào mảng sArr
            If Not Dic.exists(sArr(i, 1)) Then  'Nếu mã này chưa lọc, tức chưa có trong danh sách Dic
                Dic.Add sArr(i, 1), ""   'Thêm mã này vào danh sách Dic
                .Range("K2").Value = sArr(i, 1)  'Đặt giá trị ô K2 bằng mã chưa lọc này sArr(i,1)
                Set Ws = Worksheets.Add(, Sheet1)  'Thêm sheet mới phía sau sheet1
                Ws.Name = sArr(i, 1) 'Đặt tên sheet mới này là mã mới thêm sArr(i,1)
                .Range("A1:G28").AdvancedFilter Action:=xlFilterCopy, _
                CriteriaRange:=.Range("K1:K2"), CopyToRange:=Ws.Range("A1:G1"), Unique:=False  'Lọc danh sách dữ liệu có mã mới sArr(i,1) sang sheet mới .
                Set Rng = Ws.Range("A65000").End(xlUp)   'Đặt vùng Rng là ô cuối cùng trong cột A của sheet mới
            End If
        Next i                                                                 
        .Range("K1:K2").ClearContents   'Xóa giá trị 2 ô K1 và K2 trong sheet1 (2 Ô này là 2 ô tạm để đặt điều kiện lọc)
    End With
    Sheets(Dic.Keys).Move   'Chọn tất cả các sheet mới thêm vào và di chuyển sang file mới
    Set Dic = Nothing   'Giải phóng bộ nhớ cho danh sách Dic
    Application.ScreenUpdating = True   'Mở cập nhật màn hình
    MsgBox "Da tach xong"   'Thông báo đã thực hiện xong
End Sub

vậy là cách này là lọc dữ liệu và copy sang. Em hỏi ngu 1 tí, ví dụ giờ em khái báo 1 mảng động arrKQ(), em muốn lọc 1 mã hàng bất kỳ sau khi lọc và gán nó vào mảng động arrKQ() xong thì làm ntn để em tạo ra 1 file exce mới chỉ có 1 sheet trong đó và gán mảng arrKQ() vào trong sheet mới đó, thầy chỉ giúp em luôn với ạ! Em cảm ơn thầy!

 

[giaiphap]

vậy là cách này là lọc dữ liệu và copy sang. Em hỏi ngu 1 tí, ví dụ giờ em khái báo 1 mảng động arrKQ(), em muốn lọc 1 mã hàng bất kỳ sau khi lọc và gán nó vào mảng động arrKQ() xong thì làm ntn để em tạo ra 1 file exce mới chỉ có 1 sheet trong đó và gán mảng arrKQ() vào trong sheet mới đó, thầy chỉ giúp em luôn với ạ! Em cảm ơn thầy!

Thử sửa lại thế này.

Public Sub GPE()
Dim sArr(), i As Integer, ArrKQ(), k As Integer, Ma As String, j As Integer
Dim Wb As Workbook
   sArr() = Sheet1.Range("A2:G" & Sheet1.Range("A65000").End(xlUp).Row).Value
   ReDim ArrKQ(1 To UBound(sArr), 1 To 7)
   Ma = "CDK32"
   'Ma = InputBox("Nhap ma can loc")
    Application.ScreenUpdating = False
    With Sheet1
        For i = 1 To UBound(sArr)
                If sArr(i, 1) = Ma Then
                    k = k + 1
                    For j = 1 To 7
                        ArrKQ(k, j) = sArr(i, j)
                    Next j
                End If
        Next i
        If k Then
            Set Wb = Workbooks.Add
            .Range("A1:G1").Copy Wb.Sheets(1).Range("A1")
            Wb.Sheets(1).Range("A2:G2").Resize(k).Value = ArrKQ
            Wb.Sheets(1).Range("A2:G2").Resize(k).Borders.LineStyle = 1
            Wb.Sheets(1).Columns("A:G").EntireColumn.AutoFit
            Set Wb = Nothing
        End If
    End With
    Application.ScreenUpdating = True
    MsgBox "Da tach xong"
End Sub

 

[thaytutn]

Thử sửa lại thế này.

Public Sub GPE()
Dim sArr(), i As Integer, ArrKQ(), k As Integer, Ma As String, j As Integer
Dim Wb As Workbook
   sArr() = Sheet1.Range("A2:G" & Sheet1.Range("A65000").End(xlUp).Row).Value
   ReDim ArrKQ(1 To UBound(sArr), 1 To 7)
   Ma = "CDK32"
   'Ma = InputBox("Nhap ma can loc")
    Application.ScreenUpdating = False
    With Sheet1
        For i = 1 To UBound(sArr)
                If sArr(i, 1) = Ma Then
                    k = k + 1
                    For j = 1 To 7
                        ArrKQ(k, j) = sArr(i, j)
                    Next j
                End If
        Next i
        If k Then
            Set Wb = Workbooks.Add
            .Range("A1:G1").Copy Wb.Sheets(1).Range("A1")
            Wb.Sheets(1).Range("A2:G2").Resize(k).Value = ArrKQ
            Wb.Sheets(1).Range("A2:G2").Resize(k).Borders.LineStyle = 1
            Wb.Sheets(1).Columns("A:G").EntireColumn.AutoFit
            Set Wb = Nothing
        End If
    End With
    Application.ScreenUpdating = True
    MsgBox "Da tach xong"
End Sub

Em cám ơn thầy! Thầy giỏi quá!

Bài đã được tự động gộp: 9/10/18

Thử sửa lại thế này.

Public Sub GPE()
Dim sArr(), i As Integer, ArrKQ(), k As Integer, Ma As String, j As Integer
Dim Wb As Workbook
   sArr() = Sheet1.Range("A2:G" & Sheet1.Range("A65000").End(xlUp).Row).Value
   ReDim ArrKQ(1 To UBound(sArr), 1 To 7)
   Ma = "CDK32"
   'Ma = InputBox("Nhap ma can loc")
    Application.ScreenUpdating = False
    With Sheet1
        For i = 1 To UBound(sArr)
                If sArr(i, 1) = Ma Then
                    k = k + 1
                    For j = 1 To 7
                        ArrKQ(k, j) = sArr(i, j)
                    Next j
                End If
        Next i
        If k Then
            Set Wb = Workbooks.Add
            .Range("A1:G1").Copy Wb.Sheets(1).Range("A1")
            Wb.Sheets(1).Range("A2:G2").Resize(k).Value = ArrKQ
            Wb.Sheets(1).Range("A2:G2").Resize(k).Borders.LineStyle = 1
            Wb.Sheets(1).Columns("A:G").EntireColumn.AutoFit
            Set Wb = Nothing
        End If
    End With
    Application.ScreenUpdating = True
    MsgBox "Da tach xong"
End Sub

Thầy ơi! ở code này mặc định là lúc mình tạo ra 1 file excel chỉ có 1 sheet ah? Nếu muốn tùy biến số lượng sheet thì thêm code nào vậy thầy! Em cảm ơn thầy.

 

[snow25]

CriteriaRange:=.Range("K1:K2"), CopyToRange:=Ws.Range("A1:G1"), Unique:=False 'Lọc danh sách dữ liệu có mã mới sArr(i,1) sang sheet mới .
bạn ơi câu lệnh này lọc và copy mình muốn hỏi là muốn copy theo khoảng thời gian thì mình theo lệnh nào nhỉ
thank bạn

 

[giaiphap]

Em cám ơn thầy! Thầy giỏi quá!

Bài đã được tự động gộp: 9/10/18

Thầy ơi! ở code này mặc định là lúc mình tạo ra 1 file excel chỉ có 1 sheet ah? Nếu muốn tùy biến số lượng sheet thì thêm code nào vậy thầy! Em cảm ơn thầy.

Tôi thêm 3 sheet, còn bạn muốn bao nhiêu sheet thì sửa số 3 thành số khác.

Public Sub GPE()
Dim sArr(), i As Integer, ArrKQ(), k As Integer, Ma As String, j As Integer
Dim Wb As Workbook
   sArr() = Sheet1.Range("A2:G" & Sheet1.Range("A65000").End(xlUp).Row).Value
   ReDim ArrKQ(1 To UBound(sArr), 1 To 7)
   Ma = "CDK32"
   'Ma = InputBox("Nhap ma can loc")
    Application.ScreenUpdating = False
    With Sheet1
        For i = 1 To UBound(sArr)
                If sArr(i, 1) = Ma Then
                    k = k + 1
                    For j = 1 To 7
                        ArrKQ(k, j) = sArr(i, j)
                    Next j
                End If
        Next i
        If k Then
            Set Wb = Workbooks.Add
            .Range("A1:G1").Copy Wb.Sheets(1).Range("A1")
            Wb.Sheets(1).Range("A2:G2").Resize(k).Value = ArrKQ
            Wb.Sheets(1).Range("A2:G2").Resize(k).Borders.LineStyle = 1
            Wb.Sheets(1).Columns("A:G").EntireColumn.AutoFit
            For i = 1 To 3 'Neu muon them thi sua so 3 thanh so sheet can them
                Wb.Sheets.Add
            Next i
            Set Wb = Nothing
        End If
    End With
    Application.ScreenUpdating = True
    MsgBox "Da tach xong"
End Sub

CriteriaRange:=.Range("K1:K2"), CopyToRange:=Ws.Range("A1:G1"), Unique:=False 'Lọc danh sách dữ liệu có mã mới sArr(i,1) sang sheet mới .
bạn ơi câu lệnh này lọc và copy mình muốn hỏi là muốn copy theo khoảng thời gian thì mình theo lệnh nào nhỉ
thank bạn

Thì chổ Range("K1:K2") bạn thay bằng điều kiện lọc khác, có thể gợi ý bạn là nới rộng ra Range("K1:M2") chẳng hạn, còn áp dụng tùy vào file thực tế của bạn.