Kết quả 1 đến 5 của 5

Chủ đề: [HELP] - Code VBA tách file theo 5 cột xác định cho trước.

  1. #1
    tddhcm148 Guest

    [HELP] - Code VBA tách file theo 5 cột xác định cho trước.

    Kinh gởi A/C GPE,
    Tôi có một file báo cáo tổng được sắp xếp theo cấp quản lý theo 5 cột.
    Vậy giờ tối muốn tách file tổng(có nhiều sheet) này ra nhiều file theo từng người quản lý theo khu vực của họ.
    Ví dụ cột A là là cấp quản lý cấp 4
    cột B là là cấp quản lý cấp 3
    cột C là là cấp quản lý cấp 2
    cột D là là cấp quản lý cấp 1
    Như vậy yêu cấu sẽ tách và tạo file theo từng cột A, B, C, D..
    Tách theo số lượng khu vực mà họ quản lý.(Ví dụ Anh A ở cấp quản lý Lv2 quản lý 3 khu vực sẽ tách ra file A với dữ liệu là các khu vực anh A quản lý)
    Nhờ anh chị vui lòng giúp đỡ. Cảm ơn rất nhiều
    p/s Trong file đính kèm tối có môt tả chi tiết về yêu cầu tách.

  2. #2
    haoleluxuryhome Guest
    Có Anh/Chị nào có thể hưởng dẫn cách làm với việc tách như thế này ko ạ.
    Hiện tại tách một cột được nhưng chưa biết làm tách nhiều cột. Xin cám ơn rất nhiều

  3. #3
    chanhtan Guest
    Trích dẫn Gửi bởi subasatran
    Có Anh/Chị nào có thể hưởng dẫn cách làm với việc tách như thế này ko ạ.
    Hiện tại tách một cột được nhưng chưa biết làm tách nhiều cột. Xin cám ơn rất nhiều
    Bạn tải file thật của bạn lên. Với file full là bao nhiêu sheet để còn biết mà code. Rồi tôi xem cho...

    Không thể nói chung chung vậy được...là rất nhiều sheet, mà không biết sheet của bạn là bao nhiêu,...

    Rồi nếu muốn làm 1 lần thì tất nhiên giữa các sheet phải đồng nhất về số cột & dữ liệu tại các cột giữa các sheet là giống nhau (đồng nhất mới làm 1 lần được), và dòng tiêu đề cũng phải đồng nhất...


    Như những file ở các Topic khác của bạn tôi đã từng giúp bạn code...

    Vậy nhé!

    ============================================
    Chờ bạn phản hồi lâu quá, tôi viết luôn cho bạn với dữ liệu trên file #1
    ============================================


    Chú ý là sheet ví dụ "Structure" của bạn dữ liệu bị lệch 1 dòng so với 2 sheet chính. Cho nên muốn chạy code chính xác phải chèn thêm dòng số 2, đẩy dữ liệu bắt đầu từ dòng thứ 3 cho đồng nhất rồi chạy code sau...
    P/s: Xóa luôn mấy cái Range bạn đang Merge để mô tả vấn đề trước khi chạy code nha (chỉ để lại dữ liệu ví dụ)

    Tôi chỉ viết code phần tách file cho bạn, còn phần email thì bạn tự search trên diễn đàn ấy!



    Mã:
    Option Explicit
    
    
    Public Sub GPE()
    Dim Dic As Object, Tmp As String, Arr, Path, Rng As Range
    Dim I As Long, J As Long, K As Long, WbMain As Workbook, Ws As Worksheet
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.SheetsInNewWorkbook = 1
    Set WbMain = ThisWorkbook
    Path = ActiveWorkbook.Path
    Set Dic = CreateObject("Scripting.Dictionary")
    For J = 1 To 5
        For Each Ws In WbMain.Worksheets
        Set Rng = Ws.Range("A2", Ws.Range("A65000").End(3)).Resize(, 8)
        Arr = Ws.Range("A3", Ws.Range("A65000").End(3)).Resize(, 5).Value
        For I = 1 To UBound(Arr)
            If Arr(I, J) <> Empty Then
                Tmp = Arr(I, J)
                If Not Dic.Exists(Tmp) Then
                    K = K + 1
                    Dic.Add Tmp, K
                    With Workbooks.Add
                        Rng.AutoFilter J, Tmp
                        Ws.Range("A1", Rng).SpecialCells(12).Copy
                        .Sheets(1).Name = Ws.Name
                        .Sheets(1).Range("A1").PasteSpecial xlPasteColumnWidths
                        .Sheets(1).Range("A1").PasteSpecial xlPasteValues
                        .Sheets(1).Range("A1").PasteSpecial xlPasteFormats
                        Rng.AutoFilter
                        .Close True, ThisWorkbook.Path & "\" & Tmp & "_" & Ws.Name & ".xlsx"
                    End With
                End If
            End If
        Next I
        Ws.AutoFilterMode = False
        Dic.RemoveAll
        Next Ws
    Next J
    Set Dic = Nothing
    MsgBox "Da Tach Xong!"
    Application.SheetsInNewWorkbook = 3
    Application.CutCopyMode = False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    End Sub

  4. #4
    duongphungbds Guest

    Chờ bạn phản hồi lâu quá, tôi viết luôn cho bạn với dữ liệu trên file #1
    ===========================================

    Sự nhiệt tình sẽ giúp đở được rất nhiều người. Ngoài ra còn truyền thêm đam mê cho các bạn mới chập chững đến với VBA.


  5. #5
    linhnguyen Guest
    Nhờ sự giúp đỡ của mọi người (đặc biệt là hpkhuong [IMG]images/smilies/biggrin.png[/IMG]). Hiện tại đã sắp hoàn thành được vấn đề bấy lâu nay.
    Đến giai đoạn gởi mail(gởi qua Lotus Note) thì có 1 vần đề như thế này ko biết A/C nào có thể chỉnh lại được ko.
    Mình tìm hiểu code về send mail tự động và đã gởi được theo yêu cầu nhưng lại xảy ra thế này.
    Khi gởi mail thì file attach theo bị chuyển cái Icon file (nhìn hơi xấu mặc dù vẫn đúng định dạng) hình đóng khung bên dưới. Ai biết nguyên nhân bị như thế này ko. Bây giờ mình muốn nó vẫn là file excel như bình thường thì sửa code thế nào ?
    Thêm nữa là khi gởi mail đi thì file attack gốc với tên ví dụ là Tue_Tran.xlsx nhưng sau khi gởi thì tạo file tam xong gởi lại thì bị chuyển tên file la tue_tran.xlsx. Bây giờ muốn nó vẫn giữ lại tên file gốc (Tue Tran.xlsx) thì làm thế nào ?
    Tập Tin Ðính Kèm 158922
    Code send mail bên dưới. Mọi người sửa lại giúp. Đồng thời do code gọp nhặt lung tung nên chắc nó sẽ dư hoặc thiếu, Ai biết được chỗ sai xin tối ưu lại giúp. Cám ơn mọi người.

    Mã nguồn PHP:
    Option Explicit Const EMBED_ATTACHMENT As Long = 1454Sub Send_Mail() Dim stFileName As String Dim stPath As String Dim stSubject As String Dim vaMsg As Variant Dim vaCopyTo As Variant Dim vaEnclosure As Variant Dim vaBr As Variant Dim vaRecipients As Variant Dim cell As Range Dim noSession As Object Dim noDatabase As Object Dim noDocument As Object Dim noEmbedObject As Object Dim nAtt As Object Dim noAttachment As Object Dim stAttachment As String Dim Addresslist As Object Application.ScreenUpdating = False Set Addresslist = CreateObject("Scripting.Dictionary") stPath = Sheets("Setup").Range("I5").Value stSubject = Sheets("Setup").Range("I3").Value vaMsg = Sheets("Setup").Range("I6").Value vaCopyTo = Sheets("Setup").Range("I4").Value vaEnclosure = Sheets("Setup").Range("I12").Value vaBr = Sheets("Setup").Range("I14").Value For Each cell In Columns("D").Cells.SpecialCells(xlCellTypeConstants) If cell.Value Like "?*@?*.?*" And _ LCase(Cells(cell.Row, "E").Value) = "x" Then On Error Resume Next Addresslist.Add cell.Value, cell.Value If Err.Number = 0 Then 'Copy the active sheet to a new temporarily workbook. 'With ActiveSheet ' .Copy stFileName = LCase(Cells(cell.Row, "F").Value) 'End With stAttachment = stPath & "\" & stFileName & ".xlsx" 'Save and close the temporarily workbook. 'With ActiveWorkbook ' .SaveAs stAttachment ' .Close 'End With ' WB.SaveAs FileName:="C:\" & FileName 'Instantiate the Lotus Notes COM's Objects. Set noSession = CreateObject("Notes.NotesSession") Set noDatabase = noSession.GETDATABASE("", "") 'If Lotus Notes is not open then open the mail-part of it. If noDatabase.IsOpen = False Then noDatabase.OPENMAIL 'Create the e-mail and the attachment. Set noDocument = noDatabase.CreateDocument 'Add values to the created e-mail main properties. With noDocument Set nAtt = noDocument.CreateRichTextItem("body") .Form = "Memo" .SendTo = cell.Value .CopyTo = vaCopyTo .Subject = stSubject With nAtt .AppendText (vaMsg & vbNewLine) .AddNewLine .AddNewLine .AppendText (vaBr & vbNewLine) .AddNewLine 'Call .EmbedObject(EMBED_ATTACHMENT, "", stAttachment) '.EmbedObject (noEmbedObject) '1454 = Constant for EMBED_ATTACHMENT '1454 = Constant for EMBED_ATTACHMENT 'Set noAttachment = noDocument.CreateRichTextItem("stAttachment") Set noEmbedObject = nAtt.EmbedObject(EMBED_ATTACHMENT, "", stAttachment) '1454 = Constant for EMBED_ATTACHMENT .AddNewLine .AppendText (vaBr & vbNewLine) .AddNewLine .AppendText (Range("MailEnclosure").Value) .AddNewLine End With .SaveMessageOnSend = True .PostedDate = Now() .Send 0, cell.Value End With 'Delete the temporarily workbook. End If On Error GoTo 0 End If Next cell 'Release objects from memory. Set noEmbedObject = Nothing Set noAttachment = Nothing Set noDocument = Nothing Set noDatabase = Nothing Set noSession = Nothing MsgBox "The e-mail has successfully been created and distributed", vbInformation End Sub  

Quyền viết bài

  • Bạn Không thể gửi Chủ đề mới
  • Bạn Không thể Gửi trả lời
  • Bạn Không thể Gửi file đính kèm
  • Bạn Không thể Sửa bài viết của mình
  •