chia dữ liệu

giaosy · 29/7/09

Nhờ sự trợ giúp của bác ndu, em đã làm ra cái file này, chức năng chia dữ liệu trong sheet thành các book theo mã hàng hóa. Nhưng có vấn đề phát sinh là khi tạo workook mới thì cứ 1 wb có tên đặt theo mã hàng hóa lại phát sinh thêm 1 book trắng. Các bác chỉ giúp em cách khắc phục vấn đề này và làm sao để em có thể chỉ định được thư mục lưu các wb này (thay vì lưu mặc định vào mydoccument) với. Thanks các bác.
Đây là code:

PHP:

Sub test_chia_DL()

Dim Nwb As Workbook
'Dim Frg As Range'
Dim clls As Range
Dim NwbName As String
    
'Set Frg = activativeWorkbook.Range(Sheets("Data").[IV2], Sheets("Data").[IV65536].End(xlUp)) '
     
     Application.ScreenUpdating = False
        
        With Sheets("Data").Range("A1").CurrentRegion
            .Resize(, 1).AdvancedFilter 2, , Sheets("Data").[IV1], True
                
            For Each clls In Range(Sheets("Data").[IV2], Sheets("Data").[IV65536].End(xlUp))
                    If workbookExist = False Then
                       Workbooks.Add
            
                       Set Nwb = Workbooks.Add
                            
                            With Nwb
                                 .SaveAs Filename:=clls.Value
                            End With
                            
                     End If
                     
                        NwbName = Nwb.Name
                        
                           If bWorkbookIsOpen(NwbName) Then
Windows(NwbName).Activate.activateworkbook.Worksheets("Sheet1").Range("A1"). CurrentRegion.ClearContents
                           End If
                .AutoFilter 1, clls
                .SpecialCells(12).Copy
                 Workbooks(NwbName).Sheets("sheet1").Range("A1").PasteSpecial 3
            Next clls
                           
               .AutoFilter
        End With
        
        'Sheets("Data").Range("IV1").CurrentRegion.Clear'
        'Sh.Activate'
  
  Application.ScreenUpdating = True

End Sub

Mã:

[B]Function bWorkbookIsOpen(WbkName As String) As Boolean[/B]
    On Error Resume Next
    bWorkbookIsOpen = CBool(Len(Workbooks(rsWbkName).Name) > 0)
[B]End Function[/B]

ndu96081631 · 29/7/09

giaosy đã viết:
Nhờ sự trợ giúp của bác ndu, em đã làm ra cái file này, chức năng chia dữ liệu trong sheet thành các book theo mã hàng hóa. Nhưng có vấn đề phát sinh là khi tạo workook mới thì cứ 1 wb có tên đặt theo mã hàng hóa lại phát sinh thêm 1 book trắng. Các bác chỉ giúp em cách khắc phục vấn đề này và làm sao để em có thể chỉ định được thư mục lưu các wb này (thay vì lưu mặc định vào mydoccument) với. Thanks các bác.

Bạn Add 2 lần thì nó thêm 1 book trắng nữa thôi... chổ này nè:

PHP:

If workbookExist = False Then
  Workbooks.Add
  Set Nwb = Workbooks.Add
  Nwb.SaveAs Filename:=clls.Value
End If

Lý ra phải là:

PHP:

If workbookExist = False Then
  Set Nwb = Workbooks.Add
  Nwb.SaveAs Filename:=clls.Value
End If

add 1 lần thôi chứ
Ngoài ra không hiểu chổ này:
If workbookExist = False Then
là cái gì?
Có cảm giác như bạn đan thiếu 1 UDF nào đó thì phải
Trong code không thấy chổ nào nói đến đường dẩn thì biết chổ nào mà lưu file? Nó lưu được là may mắn rồi
Ẹc.. Ẹc...
Ít nhất phải là:

PHP:

If workbookExist = False Then
  Set Nwb = Workbooks.Add
  Nwb.SaveAs Filename:="D:\" & clls.Value '<--- Chổ này ghi đường dẩn và tên file
End If

giaosy · 29/7/09

không biết mình có lồng hàm vào trong with....endwith được không nhỉ
như thế này này:
with sheet1
incase
.....
.....
.....
exit case
endwith

giaosy · 29/7/09

to bác ndu:
đoạn này em nhầm
If workbookExist = False Then
Workbooks.Add
Set Nwb = Workbooks.Add
Nwb.SaveAs Filename:=clls.Value
End If
nó là thế này
If workbookExist <> clls.value Then
Workbooks.Add
Set Nwb = Workbooks.Add
Nwb.SaveAs Filename:=clls.Value
End If

Còn vấn đề này, em muốn hỏi bác ndu và các bác, nếu em không dùng cột A để lọc mã hàng, mà mã hàng hóa của em ở cột thứ 7 thì làm thế nào. Đoạn code em đã gửi chỉ cho phép lọc mã hàng hóa ở cột A thôi. hic
thanks bác

Hai Lúa Miền Tây · 29/7/09

To giaosy:
Mình nhờ xóa dùm bài của mình mà đâu xóa bài bạn đâu.

Mình xin "thêm mắm giặm muối" vào code của bạn 1 chút là lưu file được tách vào cùng với folder file gốc, thêm ngày tháng năm và giờ vào cho nó không trùng file.

Mã:

Sub test_chia_DL()
Dim Nwb As Workbook
'Dim Frg As Range
Dim clls As Range
Dim NwbName As String
 
 Dim strPath As String
'Set Frg = activativeWorkbook.Range(Sheets("Data").[IV2], Sheets("Data").[IV65536].End(xlUp))
        strPath = ThisWorkbook.Path
     Application.ScreenUpdating = False
        
        With Sheets("Data").Range("A1").CurrentRegion
            .Resize(, 1).AdvancedFilter 2, , Sheets("Data").[IV1], True
                
            For Each clls In Range(Sheets("Data").[IV2], Sheets("Data").[IV65536].End(xlUp))
                    If workbookExist = False Then
                      ' Workbooks.Add
            
                       Set Nwb = Workbooks.Add
                            
                            With Nwb
                                 .SaveAs Filename:=strPath & "\" & UCase(clls.Value) & " (" & Format(Now, "DD-MM-YYYY") & ") " & Format(Now, "h MM'")
                            End With
                            
                     End If
                     
                        NwbName = Nwb.Name
                        
                           If bWorkbookIsOpen(NwbName) Then
                               Windows(NwbName).Activate
                               activateworkbook.Worksheets("Sheet1").Range("A1").CurrentRegion.ClearContents
                           End If
                .AutoFilter 1, clls
                .SpecialCells(12).Copy
                 Workbooks(NwbName).Sheets("sheet1").Range("A1").PasteSpecial 3
                 Workbooks(NwbName).Save
                 Workbooks(NwbName).Close
                 
            Next clls
                           
               .AutoFilter
        End With
      
  Application.ScreenUpdating = True
End Sub
                    
Function bWorkbookIsOpen(WbkName As String) As Boolean
    On Error Resume Next
    bWorkbookIsOpen = CBool(Len(Workbooks(rsWbkName).Name) > 0)
End Function

Bạn xem thêm file nhé
Thân

ndu96081631 · 29/7/09

giaosy đã viết:
to bác ndu:
đoạn này em nhầm
If workbookExist = False Then
Workbooks.Add
Set Nwb = Workbooks.Add
Nwb.SaveAs Filename:=clls.Value
End If
nó là thế này
If workbookExist <> clls.value Then
Workbooks.Add
Set Nwb = Workbooks.Add
Nwb.SaveAs Filename:=clls.Value
End If

Còn vấn đề này, em muốn hỏi bác ndu và các bác, nếu em không dùng cột A để lọc mã hàng, mà mã hàng hóa của em ở cột thứ 7 thì làm thế nào. Đoạn code em đã gửi chỉ cho phép lọc mã hàng hóa ở cột A thôi. hic
thanks bác

Thì cũng vậy thôi... bạn đã Add 2 lần thì nó sẽ thêm 1 WB nữa...
Còn bạn lọc cột nào thì ghi địa chỉ cột đó vào ---> Như bạn nói cột 7, tức cột G đúng không? Giả sử cột này bắt đầu bằng G3 ---> Vậy bạn thay đoạn
With Sheets("Data").Range("A1").CurrentRegion
thành:
With Sheets("Data").Range(Sheets("Data").[G3],Sheets("Data").[G65536].End(xlUp))
Thế thôi...
Ngoài ra code của bạn nên rút gọn lại, đồng thời thêm 1 FileDialog để chọn đường dẩn thì hay hơn
chẳng hạn:

PHP:

Sub test_chia_DL()
  Dim Nwb As Workbook, Clls As Range, NwbName As String, FdName As String
  Application.ScreenUpdating = False
  On Error GoTo Thoat
  With Application.FileDialog(4)
    .AllowMultiSelect = False: .Show
    FdName = .SelectedItems(1)
  End With
  With Sheets("Data").Range("A1").CurrentRegion
    .Resize(, 1).AdvancedFilter 2, , Sheets("Data").[IV1], True
    For Each Clls In Range(Sheets("Data").[IV2], Sheets("Data").[IV65536].End(xlUp))
      If FileExists(FdName & "\" & Clls.Value & ".xls") = False Then
        Set Nwb = Workbooks.Add
        Nwb.SaveAs Filename:=FdName & "\" & Clls.Value
        NwbName = Nwb.Name
        If bWorkbookIsOpen(NwbName) Then
          Windows(NwbName).Activate
          ActiveWorkbook.Sheets("Sheet1").[A1].CurrentRegion.ClearContents
        End If
        .AutoFilter 1, Clls
        .SpecialCells(12).Copy
        Workbooks(NwbName).Sheets("sheet1").Range("A1").PasteSpecial 3
        Workbooks(NwbName).Close (True)
        .AutoFilter
      End If
    Next Clls
 End With
Thoat:
 Application.ScreenUpdating = True
End Sub

và 2 UDF

PHP:

Function bWorkbookIsOpen(WbkName As String) As Boolean
  On Error Resume Next
  bWorkbookIsOpen = CBool(Len(Workbooks(rsWbkName).Name) > 0)
End Function

PHP:

Function FileExists(FName) As Boolean
  On Error Resume Next
  FileExists = Len(Dir(FName)) > 0
End Function

Đây chỉ là gợi ý... Quan trọng nhất vấn là định vị vùng dử liệu cho chính xác, nếu không sẽ cho kết quả sai bét
Định vị vùng dử liệu nằm ở đoạn:
With Sheets("Data").Range("A1").CurrentRegion
Vậy bạn đưa 1 ít dử liệu gần giống với thực tế lên đây thì hay hơn (đở đoán mò)

ndu96081631 · 29/7/09

Bổ sung thêm!
Đoạn code này:

PHP:

With Application.FileDialog(4)
  .AllowMultiSelect = False: .Show
  FdName = .SelectedItems(1)
End With

Nếu thay thành:

PHP:

With CreateObject("Shell.Application")
   FdName = .BrowseForFolder(0, "CHON THU MUC LUU FILE", 1).Items.Item.Path
End With

thì càng lợi hại hơn... (Lại rất Pro...)

giaosy · 30/7/09

em fix luôn đường lưu file theo từng nhóm hàng hóa bác ndu ạ

). Cái code bác cho để chọn đường dẫn em lại ứng dụng vào cái khác, thanks bác

chia dữ liệu

giaosy

Thành viên thường trực

File đính kèm

ndu96081631

Huyền thoại GPE

giaosy

Thành viên thường trực

giaosy

Thành viên thường trực

Hai Lúa Miền Tây

❆❆❆❆❆❆❆❆

File đính kèm

ndu96081631

Huyền thoại GPE

ndu96081631

Huyền thoại GPE

giaosy

Thành viên thường trực

Bài viết mới nhất

Facebook

Group

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng