Tạo nút lệnh xuất file EXCEL theo yêu cầu (1 người xem)

[xuandongts2011]

Ví dụ trong file đính kèm mình gửi thì có dự liệu tổng hợp của các xóm : X2A,X3,X4,X5,X6 bây giờ mình muốn tạo một nút bấm mà khi bấm vào đó nó sẽ xuất cho mình dữ liệu của các xóm đó (ở đây nó sẽ xuất ra 5 file kèm theo dự liệu đã được lọc theo xóm của 5 file đó) , ai biết chỉ giúp mình, mình xin chân thành cảm ơn.

 

[nmhung49]

Ví dụ trong file đính kèm mình gửi thì có dự liệu tổng hợp của các xóm : X2A,X3,X4,X5,X6 bây giờ mình muốn tạo một nút bấm mà khi bấm vào đó nó sẽ xuất cho mình dữ liệu của các xóm đó (ở đây nó sẽ xuất ra 5 file kèm theo dự liệu đã được lọc theo xóm của 5 file đó) , ai biết chỉ giúp mình, mình xin chân thành cảm ơn.

Xem file đính kèm

[GPECODE=vb]
Sub Tach_file()


Dim Dic As Object
Dim i As Long, Data(), Sdata As Range, Xom As Variant
Set Dic = CreateObject("scripting.dictionary")
Data = Range([A6], [O65536].End(xlUp)).Value
Set Sdata = Range([A5], [O65536].End(xlUp))
With Application
.ScreenUpdating = False
.DisplayAlerts = False
For i = 1 To UBound(Data)
If Data(i, 14) <> "" Then
Dic.Item(Data(i, 14)) = ""
End If
Next
For Each Xom In Dic.keys
With Sdata
.AutoFilter 14, Xom
.Offset(-4).SpecialCells(12).Copy
Workbooks.Add
With ActiveWorkbook
With .ActiveSheet
.Name = Xom
.[A2].PasteSpecial 1
.[A:O].Columns.AutoFit
End With
.SaveAs ThisWorkbook.Path & "" & Xom, 18
.Close
End With
.AutoFilter
End With
Next


.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub


[/GPECODE]

 

[ndu96081631]

Xem file đính kèm

Sub Tach_file()
Dim Dic As Object
.......................
For i = 1 To UBound(Data)
..........................
Next
For Each Xom In Dic.keys
......................
Next
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub

Tôi nghĩ 1 vòng lập là đủ

 

[xuandongts2011]

Mình đã thử X5 và X6 không có dữ liệu bạn ơi.

 

[doveandrose]

Mình đã thử X5 và X6 không có dữ liệu bạn ơi.

à đó là vì bạn í cắt cụt mất dữ liệu của bạn rùi . Vùng dữ liệu A5:O18 bạn í đi offset(-4) nên chỉ còn lại A1:O14 , dĩ nhiên vùng này không còn X5 và X6 nữa .

 

[xuandongts2011]

Ý mình ở đây là dữ liệu xóm không thể biết trước về số dòng và số xóm , khí ấn vào nút đó đó tách ra dữ liệu theo xóm: ví dụ có 5 xóm thì nó tách ra 5 xóm , 7 xóm nó tách dữ liệu ra 7 xóm ,... , mình mong được các cao thủ chỉ giúp, mình xin chân thành cảm ơn.

 

[nmhung49]

Ý mình ở đây là dữ liệu xóm không thể biết trước về số dòng và số xóm , khí ấn vào nút đó đó tách ra dữ liệu theo xóm: ví dụ có 5 xóm thì nó tách ra 5 xóm , 7 xóm nó tách dữ liệu ra 7 xóm ,... , mình mong được các cao thủ chỉ giúp, mình xin chân thành cảm ơn.

Bạn sửa chỗ này

Set Sdata = Range([A5], [O65536].End(xlUp))

Thành

Set Sdata = Range([A5], [O65536].End(xlUp).Offset(4))

Tôi nghĩ 1 vòng lập là đủ

Tại em muốn tách ra để dễ quản lý theo dõi

 

[xuandongts2011]

Cảm ơn bạn , đã Ok rồi bạn ,song dự liệu xuất ra lại bắt đầu từ dòng thứ 2 (dong 1 trống), mình muốn dữ liệu bắt đầu từ ô đầu tiên như file gốc thì phải sửa sao vậy bạn.

 

[nmhung49]

Cảm ơn bạn , đã Ok rồi bạn ,song dự liệu xuất ra lại bắt đầu từ dòng thứ 2 (dong 1 trống), mình muốn dữ liệu bắt đầu từ ô đầu tiên như file gốc thì phải sửa sao vậy bạn.

Bạn sửa chỗ này

.[A2].PasteSpecial 1

Thành

.[A1].PasteSpecial 1

 

[xuandongts2011]

Dữ liệu lấy đến cột O thì đúng , mình muốn lấy dự liệu đến cột DE thì nó báo lỗi ở dòng .Offset(-4).SpecialCells(12).Copyác các bạn xem code chỉ mình sai chổ nào với nhé:
Sub Tach_file()
Dim Dic As Object
Dim i As Long, Data(), Sdata As Range, Xom As Variant
Set Dic = CreateObject("scripting.dictionary")
Data = Range([A6], [DE65536].End(xlUp)).Value
Set Sdata = Range([A5], [DE65536].End(xlUp).Offset(4))
With Application
.ScreenUpdating = False
.DisplayAlerts = False
For i = 1 To UBound(Data)
If Data(i, 14) <> "" Then
Dic.Item(Data(i, 14)) = ""
End If
Next
For Each Xom In Dic.keys
With Sdata
.AutoFilter 14, Xom
.Offset(-4).SpecialCells(12).Copy
Workbooks.Add
With ActiveWorkbook
With .ActiveSheet
.Name = Xom
.[A2].PasteSpecial 1
.[A:O].Columns.AutoFit
End With
.SaveAs ThisWorkbook.Path & "" & Xom, 18
.Close
End With
.AutoFilter
End With
Next
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub

 

[xuandongts2011]

Mõi người xem giúp mình với nhé, mình đang rất cần.

 

[nmhung49]

Mõi người xem giúp mình với nhé, mình đang rất cần.

Bạn chỉnh lại đoạn code cũ

.Offset(-4).SpecialCells(12).Copy

Thành thế này xem

.Offset(-4).Copy

Khi dùng code cũ bị lỗi tràn bộ nhớ khi dữ liệu nhiều

 

[xuandongts2011]

Nó chỉ tách đến cột O là đúng ,mình thì muốn tách đến cột DE , mõi người xem file đính kèm giúp mình với nhé. đặc biệt bạn nmhung49 giúp mình với nhé.

 

[xuandongts2011]

Mình đã thay .Offset(-4).SpecialCells(12).Copy Thành .Offset(-4).Copy vẫn không được , bạn xem trong file đính kèm giúp mình với nhé.

 

[befaint]

Mình đã thay .Offset(-4).SpecialCells(12).Copy Thành .Offset(-4).Copy vẫn không được , bạn xem trong file đính kèm giúp mình với nhé.

Chào xuandongts2011,

Tôi làm kiểu vầy (ngồi nhìn nó chớp chớp vui mắt )
Mời bạn xem file.
p/s: Có nút đểm bấm đàng hoàng nha.

Sub TachFile()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
Dim rng As Range, i As Long, lr As Long, path As String, tmp(), sh As Worksheet, r As Long
Set sh = ThisWorkbook.Sheets(1)
path = ThisWorkbook.path & "\"
lr = sh.Range("N65000").End(3).Row
Set rng = sh.Range("N5:N" & lr)
tmp = rng.Value
On Error Resume Next
For i = 1 To UBound(tmp)
    If tmp(i, 1) <> "" And Not Dic.Exists(tmp(i, 1)) Then
    sh.Copy
    With ActiveWorkbook
        For r = lr To 5 Step -1
            If .Sheets(1).Range("N" & r).Value <> tmp(i, 1) Then .Sheets(1).Rows(r).Delete
        Next r
        .Sheets(1).Shapes(1).Delete
        .SaveAs Filename:=path & tmp(i, 1) & ".xls", FileFormat:=xlExcel8
        .Close
    End With
    End If
Next i
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

 

[xuandongts2011]

Bạn xem file đính kèm ở #13 giúp mình với ,ở file đính kèm #13 mình chọn đến cột O là chạy OK , trên cơ sở code đó mình mở rộng vùng chọn đến cột DE là không chạy được.

 

[nmhung49]

Bạn xem file đính kèm ở #13 giúp mình với ,ở file đính kèm #13 mình chọn đến cột O là chạy OK , trên cơ sở code đó mình mở rộng vùng chọn đến cột DE là không chạy được.

Tôi đã chỉnh lại cho bạn do file bạn merge nên tôi chèn thêm dòng 5 để thuận tiện cho filter và tôi đã kéo dòng đó nhỏ lại cho không thấy, code trên không chạy do bạn xác định dòng cuối cùng không có dữ liệu của cột DE là dòng 4 nên code không hoạt động, tôi có chú thích code trong đó