Xin Nhờ Anh Chị Viết em Code tách file

Nga2022 · 21/7/22

Xin chào anh chị em muốn nhờ anh chị giúp em viết code tách file với nội dung sau
1. Tạo 1 code Tách một chủ sử dụng bất kỳ ra từng 1 file riêng, tên file đặt tên theo cột: mã [So TT] và được lưu gọn trong 1 folder (hộp thoại đính kèm)
2. Tự động Tách các chủ sử dụng ra từng file riêng, tên file đặt tên theo cột: mã [So TT] và được lưu gọn trong 1 folder
3. Khi lưu file chỉ lấy những cột có ký tự tiêu đề riêng sau: ( Mục đích tránh sau này khi chèn cột, thêm cột mới mà import dữ liệu củ sẽ sinh ra lệch cột).
Em xin chân thành cảm ơn anh chị ạ

[So TT]

[Hoten]

[namSinh]

[soGiayTo]

[ngayCap]

[noiCap]

[diaChiChu]

[Hoten2]

[namSinh2]

[soGiayTo2]

[ngayCap2]

[noiCap2]

[diaChiChu2]

Nga2022 · 21/7/22

Cả nhà ơi cả nhà giúp em với lần đầu tham gia diễn đàn mà không có ai ngó ngàng buồn quá

Hoàng Tuấn 868 · 21/7/22

Nga2022 đã viết:
Cả nhà ơi cả nhà giúp em với lần đầu tham gia diễn đàn mà không có ai ngó ngàng buồn quá

Các thành viên còn đang giúp những người nhờ trước bạn, khi nào xong thì đến lượt bạn thôi.

snow25 · 21/7/22

Nga2022 đã viết:
Xin chào anh chị em muốn nhờ anh chị giúp em viết code tách file với nội dung sau
1. Tạo 1 code Tách một chủ sử dụng bất kỳ ra từng 1 file riêng, tên file đặt tên theo cột: mã [So TT] và được lưu gọn trong 1 folder (hộp thoại đính kèm)
2. Tự động Tách các chủ sử dụng ra từng file riêng, tên file đặt tên theo cột: mã [So TT] và được lưu gọn trong 1 folder
3. Khi lưu file chỉ lấy những cột có ký tự tiêu đề riêng sau: ( Mục đích tránh sau này khi chèn cột, thêm cột mới mà import dữ liệu củ sẽ sinh ra lệch cột).
Em xin chân thành cảm ơn anh chị ạ

[So TT] [Hoten] [namSinh] [soGiayTo] [ngayCap] [noiCap] [diaChiChu] [Hoten2] [namSinh2] [soGiayTo2] [ngayCap2] [noiCap2] [diaChiChu2]

Nhất thiết phải tách sang work à bạn.

Nga2022 · 21/7/22

Dạ không anh ơi tách sang file excel anh à

VetMini · 21/7/22

Bạn lập thử một file giả tạo. Cỡ 20 dòng dữ liệu.
Sau đó bạn lập cách files như được tách ra.
Người ta sẽ dựa vào ví dụ ấy mà viết code cho bạn.

Chớ lười biếng. Làm files ví dụ như vậy không tốn công và thì giờ nhiều hơn người ta viết code giùm bạn đâu.

Nga2022 · 21/7/22

Dạ Vâng anh. em giử Các anh các chị một số file kết quả sau khi tách ra như sau ạ
Mong anh chị giúp em với. Em xin cảm ơn anh chị nhiều ạ

Nga2022 · 21/7/22

Mong ngóng Các anh các chị trong diễn đàn code giúp e với

batman1 · 22/7/22

Nga2022 đã viết:
Mong ngóng Các anh các chị trong diễn đàn code giúp e với

Trong lúc chờ đợi các anh chị thì bạn thử code sau.

Ví dụ thêm 1 Module và dán vào code sau

Mã:

Sub ghi_1_dong()
Dim lastRow As Long, r As Long, rng As Range, sh As Worksheet
    Application.ScreenUpdating = False
   
    Set sh = ThisWorkbook.Worksheets("Sheet1")
    With sh
        lastRow = .Range("A" & Rows.Count).End(xlUp).Row
        If lastRow < 2 Then Exit Sub
        .Copy
    End With
    Set rng = ActiveWorkbook.Worksheets(1).UsedRange.Offset(1)
    rng.ClearContents
    Set rng = rng.Resize(1)
   
    Application.DisplayAlerts = False   ' khong hien cua so khi da co tap tin voi ten hien hanh do vd. chay code lan 2
    For r = 2 To lastRow
        rng.Value = sh.Range("A" & r).Resize(1, rng.Columns.Count).Value
        rng.Parent.SaveAs ThisWorkbook.Path & "\" & sh.Range("A" & r).Value & ".xlsx", xlOpenXMLWorkbook
    Next r
    rng.Parent.Parent.Close
    Application.DisplayAlerts = True
   
    Application.ScreenUpdating = True
End Sub

Nga2022 · 22/7/22

Cảm ơn anh em xin nhờ anh sửa code chỉ lấy những cột có ký tự tiêu đề riêng sau

[So TT]

[Hoten]

[namSinh]

[soGiayTo]

[ngayCap]

[noiCap]

[diaChiChu]

[Hoten2]

[namSinh2]

[soGiayTo2]

[ngayCap2]

[noiCap2]

[diaChiChu2]

( Mục đích tránh sau này khi chèn cột, thêm cột mới mà import dữ liệu củ sẽ sinh ra lệch cột).

Nga2022 · 22/7/22

Anh batman1 anh có bổ sung code cho em 1 cái hộp thoại chọn dòng không anh. như hình dưới đây anh À. Xin cảm ơn anh nhiều

batman1 · 22/7/22

Nga2022 đã viết:
Anh batman1 anh có bổ sung code cho em 1 cái hộp thoại chọn dòng không anh. như hình dưới đây anh À. Xin cảm ơn anh nhiều

1. Nếu thêm bớt tiêu đề cần lấy thì thêm bớt sau dấu bằng "="

Mã:

tieude = "[Hoten][namSinh][soGiayTo][ngayCap][noiCap][diaChiChu][Hoten2][namSinh2][soGiayTo2][ngayCap2][noiCap2][diaChiChu2]"

2. Các tiêu đề liệt kê ở trên phải theo đúng thứ tự trước sau giống như trong tập tin gốc.

3.

Mã:

Sub ghi_1_dong()
Dim lastRow As Long, lastCol As Long, c As Long, k As Long, dong As Long, kq(), rng As Range, tieude As String, tencot As String
    tieude = "[Hoten][namSinh][soGiayTo][ngayCap][noiCap][diaChiChu][Hoten2][namSinh2][soGiayTo2][ngayCap2][noiCap2][diaChiChu2]"
    Application.ScreenUpdating = False
  
'    Set sh = ThisWorkbook.Worksheets("Sheet1")
    With ThisWorkbook.Worksheets("Sheet1")
        On Error Resume Next
        Set rng = Application.InputBox(prompt:="Hay chon mot o cua dong hien hanh", Type:=8)
        If rng Is Nothing Then Exit Sub ' neu khong chon thi nghi choi
        On Error GoTo 0
        dong = rng.Row
        lastRow = .Range("A" & Rows.Count).End(xlUp).Row
        If lastRow < 2 Then Exit Sub    ' neu chi co dong tieu de thi don do choi
        lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
        If lastCol < 2 Then Exit Sub    ' neu chi co cot STT thi don do choi
        Set rng = .Range("B1").Resize(1, lastCol - 1)  ' lay tu cot B - dong tieu de trong tap tin goc
        ReDim kq(1 To 2, 1 To rng.Columns.Count)    ' mang ket qua co so cot nhieu nhat la bang so cot TIEU DE tinh tu cot B
       
        For c = 1 To rng.Count
            tencot = rng(c).Value
            If InStr(1, tieude, tencot, vbTextCompare) Then ' neu tieu de cot trong tap tin goc la tieu de can lay
                k = k + 1
                kq(1, k) = tencot   ' tieu de cot
                kq(2, k) = rng(c).Offset(dong - 1).Value    ' gia tri
            End If
        Next c
        If k Then
            Application.Workbooks.Add   ' them tap tin moi
            ActiveWorkbook.Worksheets(1).Range("A1").Resize(2, k).Value = kq
            Application.DisplayAlerts = False   ' khong hien cua so khi da co tap tin voi ten hien hanh do vd. chay code lan 2
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & rng(1).Offset(dong - 1, -1).Value & ".xlsx", xlOpenXMLWorkbook
            ActiveWorkbook.Close False
            Application.DisplayAlerts = True
        End If
    End With
    Application.ScreenUpdating = True
End Sub

4. Các tập tin được lưu trong thư mục có tập tin gốc.

Nga2022 · 22/7/22

Hay quá anh chỉ xin anh viết tiếp cho em 1 code chạy toàn bộ các dòng cũng dựa vào tiêu đề này và tự động tạo foder có trên là Tron
Em xin chân thành cảm ơn anh

batman1 · 22/7/22

Nga2022 đã viết:
Hay quá anh chỉ xin anh viết tiếp cho em 1 code chạy toàn bộ các dòng cũng dựa vào tiêu đề này và tự động tạo foder có trên là Tron
Em xin chân thành cảm ơn anh

Có nghĩa không chọn dòng cụ thể nữa mà ghi cho tất cả các dòng? Tạo thư mục Tron ở đâu?

Có khi tối (hiện chỗ tôi là 13:24) tôi mới có thời gian.

Nếu là Mail Merge của Word thì chịu khó học đi. Dùng code VBA của người khác thay cho Mail Merge thì cũng không phải toàn hoa hồng như người ta giới thiệu đâu. Mà cái cớ Mail Merge khó thì có vẻ hài quá. Viện cớ là chọn Mailing xong không biết làm gì tiếp, khi chỉ là Insert Merge Field, thì có câu hỏi. Khi dùng code VBA của người khác không cần tìm hiểu, học, luyện tới hộc cơm?

ongke0711 · 22/7/22

Chủ thớt này có vẻ quen..

. Bạn tạo nick khác để hỏi thêm bài à.

batman1 · 22/7/22

ongke0711 đã viết:
Chủ thớt này có vẻ quen... Bạn tạo nick khác để hỏi thêm bài à.

Thời nay mấy em gái cũng lanh lợi chứ không như ngày xưa đâu.

Hoặc là anh chàng nào đấy làm rồi "đổ thừa" cho mấy em gái hiền dịu.

Nga2022 · 22/7/22

Ủa anh đi làm ở nước ngoài à anh. Không phải dùng Mail Merge của Word anh à. Dùng lưu trữ dữ liệu anh à
Thêm chức năng ghi cho tất cả các dòng và tao foder như hình vẽ anh à.

batman1 · 22/7/22

Tôi lười nên không viết mới mà chỉ sửa code đã có trước đó.

Tôi sửa lại code sau khi có báo cáo lỗi ở bài #35

Mã:

Sub tao_thumuc(ByVal foldername As String)
Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(foldername) Then fso.CreateFolder (foldername)
    Set fso = Nothing
End Sub

Sub ghi_tung_dong()
Dim lastRow As Long, lastCol As Long, r As Long, c As Long, kq(), tieude As String, tencot As String, filename As String, files(), xoa As Range
    tieude = "[Hoten][namSinh][soGiayTo][ngayCap][noiCap][diaChiChu][Hoten2][namSinh2][soGiayTo2][ngayCap2][noiCap2][diaChiChu2]"
    Application.ScreenUpdating = False
    
    With ThisWorkbook.Worksheets("Sheet1")
        lastRow = .Range("A" & Rows.Count).End(xlUp).Row
        If lastRow < 2 Then Exit Sub    ' neu chi co dong tieu de thi don do choi
        lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
        If lastCol < 2 Then Exit Sub    ' neu chi co cot STT thi don do choi
        tao_thumuc ThisWorkbook.Path & "\Tron"
        .Copy   ' sao chep sheet hien hanh sang tap tin moi
    End With
    
    With ActiveWorkbook.Worksheets(1)   ' chinh sua tap tin moi hien hanh
        files = .Range("A1").Resize(lastRow).Value  ' cot STT chua ten cac tap tin
        For c = 1 To lastCol    ' xoa tat ca cac cot khong can lay du lieu
            tencot = .Cells(1, c).Value
            If InStr(1, tieude, tencot, vbTextCompare) = 0 Then
                If xoa Is Nothing Then
                    Set xoa = .Cells(1, c)
                Else
                    Set xoa = Union(xoa, .Cells(1, c))
                End If
            End If
        Next c
        If Not xoa Is Nothing Then xoa.EntireColumn.Delete  ' xoa cac cot khong can lay du lieu neu co
        lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
        If .Range("A1").Value = "" Then Exit Sub    ' neu sau khi xoa cac cot khong can lay du lieu ma khong con du lieu thi don do choi
        kq = .Range("A1").Resize(lastRow, lastCol).Value    ' mang du lieu can lay, dung mang kq dong thoi lam mang ket qua
        .Range("A1").Resize(lastRow, lastCol).ClearContents ' xoa het du lieu trong tap tin hien hanh
    End With
    For r = 2 To UBound(kq, 1)
        filename = files(r, 1)
        If Len(filename) Then   ' neu ten tap tin <> RONG thi moi thuc hien
            For c = 1 To UBound(kq, 2)
                kq(2, c) = kq(r, c) ' sao chep dong r cua mang kq vao dong 2
            Next c
            ActiveWorkbook.Worksheets(1).Range("A1").Resize(2, UBound(kq, 2)).Value = kq    ' chi ghi 2 dong dau tu mang vao sheet hien hanh
            Application.DisplayAlerts = False   ' khong hien cua so khi da co tap tin voi ten hien hanh do vd. chay code lan 2
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\Tron\" & filename & ".xlsx", xlOpenXMLWorkbook
            Application.DisplayAlerts = True
        End If
    Next r
    ActiveWorkbook.Close False
    Application.ScreenUpdating = True
End Sub

Nga2022 · 22/7/22

Cảm ơn anh. Lúc đầu em không nghỉ ra Giờ muốn Import lại các file đã xuất ra theo những cột có ký tự tiêu đề riêng mà code trên đã chạy ra để tổng hợp thì code như thế nào anh chứ ngồi mở từng file copy thì lâu lắm anh ơi (Bài toán ngược lại anh à)

batman1 · 23/7/22

Nga2022 đã viết:
Cảm ơn anh. Lúc đầu em không nghỉ ra Giờ muốn Import lại các file đã xuất ra theo những cột có ký tự tiêu đề riêng mà code trên đã chạy ra để tổng hợp thì code như thế nào anh chứ ngồi mở từng file copy thì lâu lắm anh ơi (Bài toán ngược lại anh à)

Tôi cho phép bạn nghĩ thật kỹ và nói hết trong 1 bài nữa. Sau đó tôi chỉ giúp bạn lần cuối. Không có chuyện rồi bạn thêm yêu cầu, "không nghĩ ra". Tôi không ngồi chờ để cầy hộ bạn.
Muốn có code cho "bài toán ngược lại" thì giải thích kỹ nó là gì. Dữ liệu đầu vào là gì, lấy từ đâu. Có cái đó thì những bước tiếp theo phải làm gì. Tức liệ́t kê tất cả các bước nếu làm bằng tay. Nếu tôi hiểu thì tôi giụ́p, không hiểu thì thôi. Không có chuyện tôi lại phải van nài, hướng dẫn cách cung cấp thông tin.

Xin Nhờ Anh Chị Viết em Code tách file

Thành viên mới

File đính kèm

Thành viên mới

Đăng ký hôm qua

Thành viên gạo cội

Thành viên mới

Ăn cùng góc phố

Thành viên mới

File đính kèm

Thành viên mới

Thành viên gạo cội

Thành viên mới

File đính kèm

Thành viên mới

File đính kèm

Thành viên gạo cội

Thành viên mới

Thành viên gạo cội

Thành viên gắn bó

Thành viên gạo cội

Thành viên mới

File đính kèm

Thành viên gạo cội

Thành viên mới

Thành viên gạo cội