GIÚP ĐỠ TẠO NHIỀU FILE

Liên hệ QC
H

Hoàng Đình Huy

Thành viên mới
Tham gia
24/11/17
Bài viết
26
Được thích
1
Giới tính
Nam
Em tạo được 1 file rồi nhưng chưa biết cách tạo nhiều file ạ.
 

File đính kèm

  • Test code.xlsm
    1.5 MB · Đọc: 15
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Hoàng Đình Huy đã viết:
Em tạo được 1 file rồi nhưng chưa biết cách tạo nhiều file ạ.
Nhấp chuột vào đây để mở rộng...
Góp ý cho bạn:
1/ Đọc xong chẳng hiểu bạn muốn làm cái gì luôn.
2/ Bạn nên giải trình vấn đề càng cụ thể, rõ ràng, càng chi tiết thì càng tốt,.
3/ Bạn nêu tạo nhiều file thì chẳng ai hiểu bạn muốn làm cái gì, ở đâu? của sheet nào hay tất cả các sheet mỗi sheet là 1 File hay tách dữ liệu của 1 sheet.
 
Upvote 0
be09 đã viết:
Góp ý cho bạn:
1/ Đọc xong chẳng hiểu bạn muốn làm cái gì luôn.
2/ Bạn nên giải trình vấn đề càng cụ thể, rõ ràng, càng chi tiết thì càng tốt,.
3/ Bạn nêu tạo nhiều file thì chẳng ai hiểu bạn muốn làm cái gì, ở đâu? của sheet nào hay tất cả các sheet mỗi sheet là 1 File hay tách dữ liệu của 1 sheet.
Nhấp chuột vào đây để mở rộng...

dạ em cảm ơn anh đã góp ý ạ.

Nội dung em cần là:
- Sheet Chi tiet DMS, cột ASM có 22 người khác nhau, giờ em muốn tạo 22 file, mỗi file lưu 1 người
- Mỗi file sẽ có 2 sheet, 1 là DMS (paste value), 2 là Chi tiet DMS ứng với từng người ạ
 
Upvote 0
Hoàng Đình Huy đã viết:
dạ em cảm ơn anh đã góp ý ạ.

Nội dung em cần là:
- Sheet Chi tiet DMS, cột ASM có 22 người khác nhau, giờ em muốn tạo 22 file, mỗi file lưu 1 người
- Mỗi file sẽ có 2 sheet, 1 là DMS (paste value), 2 là Chi tiet DMS ứng với từng người ạ
Nhấp chuột vào đây để mở rộng...
Bạn gửi 1 file dữ liệu cần xuất ra như thế nào cho mọi người dễ hình dung (như là form mẫu, bao gồm tên file mới cần lưu là gì nữa)
 
Upvote 0
Dạ em mong muốn trả tạo ra giống file như vậy ạ (đây là file tháng 8 em làm ạ)

1598666740929.png


Trong file có ở sheet 1: toàn bộ sheet 1 là chuyển về paste value
1598666814230.png

Ở sheet 2:
1598667201496.png


Đây là link chi tiết các kết quả trả về ạ:

ASM - Google Drive

drive.google.com drive.google.com
 

File đính kèm

  • 1598666710953.png
    1598666710953.png
    407.7 KB · Đọc: 1
  • 1598666842803.png
    1598666842803.png
    490.3 KB · Đọc: 1
Upvote 0
Bài của bạn làm trên Google sheets à. hay là file thường trên máy tính cá nhân thế?
 
Upvote 0
Hoàng Đình Huy đã viết:
Dạ em mong muốn trả tạo ra giống file như vậy ạ (đây là file tháng 8 em làm ạ)

View attachment 244403


Trong file có ở sheet 1: toàn bộ sheet 1 là chuyển về paste value
View attachment 244404

Ở sheet 2:
View attachment 244408


Đây là link chi tiết các kết quả trả về ạ:

ASM - Google Drive

drive.google.com drive.google.com
Nhấp chuột vào đây để mở rộng...
Sheet1 chưa bỏ đi những cột không cần thiết (mình đưa cả sheet NPP qua luôn)
Bạn test thử nha, thiếu sót gì nhờ anh chị khác bổ sung hoặc làm mới nhé!
PHP: 
Sub TachSheet()
Dim sPath As String, sWb As Workbook, dWb As Workbook, nWs As Worksheet, Dic As Object, NameArr(), I&, J&
Dim Ngay&, ThangNam As String
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
    .Calculation = xlCalculationManual
End With
Set sWb = ThisWorkbook
sPath = sWb.Path
Set Dic = CreateObject("Scripting.Dictionary")
With sWb
    Ngay = Day(Sheets("Chi Tiet DMS").Range("K2"))
    ThangNam = " T" & Month(Sheets("Chi Tiet DMS").Range("K2")) & "." & Year(Sheets("Chi Tiet DMS").Range("K2"))
    If Not Sheets("Chi Tiet DMS").AutoFilterMode = False Then
        .Range("Table1[[#Headers],[Tên NPP]:[ASM]]").AutoFilter

    End If
        Sheets("Chi Tiet DMS").ListObjects("Table1").AutoFilter.ShowAllData
        NameArr = Sheets("Chi Tiet DMS").Range("Table1[ASM]").Value
End With
For I = 1 To UBound(NameArr, 1)
If Not Dic.exists(NameArr(I, 1)) Then
    Dic.Add (NameArr(I, 1)), NameArr(I, 1)
End If
Next
For Each Key In Dic.keys
    J = J + 1
    sWb.Sheets("NPP").Copy
    Set dWb = ActiveWorkbook
    With dWb
        Cells.Copy
        Cells.PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        'xoa cot gi thuc hien vao day
        .Sheets("NPP").Name = "Sheet1"
        Sheets.Add after:=Sheets(Sheets.Count)
            With ActiveSheet
                sWb.Sheets("Chi Tiet DMS").ListObjects("Table1").Range.AutoFilter Field:=11, Criteria1:=Key
                sWb.Sheets("Chi Tiet DMS").Range("A1:K" & sWb.Sheets("Chi Tiet DMS").Range("K" & Rows.Count).End(3).Row).Copy
                .Range("A1").PasteSpecial (xlPasteValues)
            End With
    End With
    'K?T QU? TB MVO AUDIT_DMS 25 T8.2020 _ ASM Bùi T?n Phúc
    dWb.Close True, sPath & "\KET QUA TB MVO AUDIT_DMS " & Ngay & ThangNam & "_ASM " & Key & ".xlsx"
Next
Set Dic = Nothing
MsgBox "Hoan thanh " & J & " file!"
With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
    .Calculation = xlCalculationAutomatic
End With
End Sub
 

File đính kèm

  • Test code.xlsm
    1.7 MB · Đọc: 12
Upvote 0
buiquangthuan đã viết:
Bài của bạn làm trên Google sheets à. hay là file thường trên máy tính cá nhân thế?
Nhấp chuột vào đây để mở rộng...
dạ máy công ty ạ
Bài đã được tự động gộp:

Nhattanktnn đã viết:
Sheet1 chưa bỏ đi những cột không cần thiết (mình đưa cả sheet NPP qua luôn)
Bạn test thử nha, thiếu sót gì nhờ anh chị khác bổ sung hoặc làm mới nhé!
PHP: 
Sub TachSheet()
Dim sPath As String, sWb As Workbook, dWb As Workbook, nWs As Worksheet, Dic As Object, NameArr(), I&, J&
Dim Ngay&, ThangNam As String
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
    .Calculation = xlCalculationManual
End With
Set sWb = ThisWorkbook
sPath = sWb.Path
Set Dic = CreateObject("Scripting.Dictionary")
With sWb
    Ngay = Day(Sheets("Chi Tiet DMS").Range("K2"))
    ThangNam = " T" & Month(Sheets("Chi Tiet DMS").Range("K2")) & "." & Year(Sheets("Chi Tiet DMS").Range("K2"))
    If Not Sheets("Chi Tiet DMS").AutoFilterMode = False Then
        .Range("Table1[[#Headers],[Tên NPP]:[ASM]]").AutoFilter

    End If
        Sheets("Chi Tiet DMS").ListObjects("Table1").AutoFilter.ShowAllData
        NameArr = Sheets("Chi Tiet DMS").Range("Table1[ASM]").Value
End With
For I = 1 To UBound(NameArr, 1)
If Not Dic.exists(NameArr(I, 1)) Then
    Dic.Add (NameArr(I, 1)), NameArr(I, 1)
End If
Next
For Each Key In Dic.keys
    J = J + 1
    sWb.Sheets("NPP").Copy
    Set dWb = ActiveWorkbook
    With dWb
        Cells.Copy
        Cells.PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        'xoa cot gi thuc hien vao day
        .Sheets("NPP").Name = "Sheet1"
        Sheets.Add after:=Sheets(Sheets.Count)
            With ActiveSheet
                sWb.Sheets("Chi Tiet DMS").ListObjects("Table1").Range.AutoFilter Field:=11, Criteria1:=Key
                sWb.Sheets("Chi Tiet DMS").Range("A1:K" & sWb.Sheets("Chi Tiet DMS").Range("K" & Rows.Count).End(3).Row).Copy
                .Range("A1").PasteSpecial (xlPasteValues)
            End With
    End With
    'K?T QU? TB MVO AUDIT_DMS 25 T8.2020 _ ASM Bùi T?n Phúc
    dWb.Close True, sPath & "\KET QUA TB MVO AUDIT_DMS " & Ngay & ThangNam & "_ASM " & Key & ".xlsx"
Next
Set Dic = Nothing
MsgBox "Hoan thanh " & J & " file!"
With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
    .Calculation = xlCalculationAutomatic
End With
End Sub
Nhấp chuột vào đây để mở rộng...

Dạ anh ơi, anh cho em hỏi nó bị lỗi gì ấy ạ\
1598676083501.png


1598676058532.png
 
Upvote 0
Upvote 0
Upvote 0
Upvote 0
Upvote 0
Nhattanktnn đã viết:
Nay mình hơi bận, để lát xem có thời gian thì mình xem lại cho. Không thì phải chờ ngày mai mình nghỉ mới làm được
Nhấp chuột vào đây để mở rộng...
dạ em cảm ơn anh ạ, mai cũng được ạ <3
Bài đã được tự động gộp:

Nhattanktnn đã viết:
Nay mình hơi bận, để lát xem có thời gian thì mình xem lại cho. Không thì phải chờ ngày mai mình nghỉ mới làm được
Nhấp chuột vào đây để mở rộng...
Em cảm ơn anh nhiều lắm ạ <3
 
Upvote 0
Hoàng Đình Huy đã viết:
dạ em cảm ơn anh ạ, mai cũng được ạ <3
Bài đã được tự động gộp:


Em cảm ơn anh nhiều lắm ạ <3
Nhấp chuột vào đây để mở rộng...
Qua hứa nay giúp bạn nên phải tranh thủ vào làm giữ lời hứa
Bạn nên tạo một folder riêng chứa file này để khi chạy ra các file nhỏ nằm trong một thư mục khỏi lộn xộn nhiều file
PHP: 
Sub TachSheet()
Dim sWb As Workbook, dWb As Workbook, nWs As Worksheet, Dic As Object
Dim NameArr(), I&, J&, K&, ctLr&
Dim Ngay&, ThangNam As String, sPath As String, Lob As Object
'******************************************************************************
With Application
    .CopyObjectsWithCells = False
    .ScreenUpdating = False
    .DisplayAlerts = False
    .Calculation = xlCalculationManual
End With
'******************************************************************************
Set Dic = CreateObject("Scripting.Dictionary")
Set sWb = ThisWorkbook
sPath = sWb.Path
'******************************************************************************
With sWb.Sheets("Chi Tiet DMS")
    ctLr = .Range("K" & Rows.Count).End(3).Row
    Ngay = Day(.Range("K2"))
    ThangNam = " T" & Month(.Range("K2")) & "." & Year(.Range("K2"))
    Set Lob = .ListObjects("Table1")
    If Lob.ShowAutoFilter Then
        Lob.AutoFilter.ShowAllData
    Else
        Lob.ShowAutoFilter = True
    End If
    NameArr = Lob.ListColumns(11).DataBodyRange.Value
End With
'******************************************************************************
For I = 1 To UBound(NameArr, 1)
If Not Dic.exists(NameArr(I, 1)) Then
    Dic.Add (NameArr(I, 1)), ""
End If
Next
For Each Key In Dic.keys
    J = J + 1
    sWb.Sheets("NPP").Copy
        Cells.Copy
        Cells.PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        'xoa cot gi thuc hien vao day
        Set dWb = ActiveWorkbook
        dWb.Sheets("NPP").Name = "Sheet1"
   
    sWb.Sheets("Chi Tiet DMS").Copy after:=dWb.Sheets("Sheet1")
        Cells.Copy
        Cells.PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        With dWb.Sheets("Chi Tiet DMS")
        Set Lob = .ListObjects("Table1")
            .Columns("L:XFD").Clear
            .Name = "Sheet2"
            Lob.Range.AutoFilter Field:=11, Criteria1:="<>" & Key
            Lob.DataBodyRange.Delete
            Lob.AutoFilter.ShowAllData
                For Each cell In Lob.ListColumns(1).DataBodyRange
                    K = K + 1
                    cell.Value = K
                Next
                   
        End With
    'K?T QU? TB MVO AUDIT_DMS 25 T8.2020 _ ASM Bùi T?n Phúc
    dWb.Close True, sPath & "\KET QUA TB MVO AUDIT_DMS " & Ngay & ThangNam & "_ASM " & Key & ".xlsx"
Next
'******************************************************************************
Set Dic = Nothing
MsgBox "Hoan thanh " & J & " file!"
With Application
    .CopyObjectsWithCells = True
    .ScreenUpdating = True
    .DisplayAlerts = True
    .Calculation = xlCalculationAutomatic
End With
End Sub
 

File đính kèm

  • Test code.xlsm
    1.5 MB · Đọc: 8
Upvote 0
Nhattanktnn đã viết:
Qua hứa nay giúp bạn nên phải tranh thủ vào làm giữ lời hứa
Bạn nên tạo một folder riêng chứa file này để khi chạy ra các file nhỏ nằm trong một thư mục khỏi lộn xộn nhiều file
PHP: 
Sub TachSheet()
Dim sWb As Workbook, dWb As Workbook, nWs As Worksheet, Dic As Object
Dim NameArr(), I&, J&, K&, ctLr&
Dim Ngay&, ThangNam As String, sPath As String, Lob As Object
'******************************************************************************
With Application
    .CopyObjectsWithCells = False
    .ScreenUpdating = False
    .DisplayAlerts = False
    .Calculation = xlCalculationManual
End With
'******************************************************************************
Set Dic = CreateObject("Scripting.Dictionary")
Set sWb = ThisWorkbook
sPath = sWb.Path
'******************************************************************************
With sWb.Sheets("Chi Tiet DMS")
    ctLr = .Range("K" & Rows.Count).End(3).Row
    Ngay = Day(.Range("K2"))
    ThangNam = " T" & Month(.Range("K2")) & "." & Year(.Range("K2"))
    Set Lob = .ListObjects("Table1")
    If Lob.ShowAutoFilter Then
        Lob.AutoFilter.ShowAllData
    Else
        Lob.ShowAutoFilter = True
    End If
    NameArr = Lob.ListColumns(11).DataBodyRange.Value
End With
'******************************************************************************
For I = 1 To UBound(NameArr, 1)
If Not Dic.exists(NameArr(I, 1)) Then
    Dic.Add (NameArr(I, 1)), ""
End If
Next
For Each Key In Dic.keys
    J = J + 1
    sWb.Sheets("NPP").Copy
        Cells.Copy
        Cells.PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        'xoa cot gi thuc hien vao day
        Set dWb = ActiveWorkbook
        dWb.Sheets("NPP").Name = "Sheet1"
  
    sWb.Sheets("Chi Tiet DMS").Copy after:=dWb.Sheets("Sheet1")
        Cells.Copy
        Cells.PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        With dWb.Sheets("Chi Tiet DMS")
        Set Lob = .ListObjects("Table1")
            .Columns("L:XFD").Clear
            .Name = "Sheet2"
            Lob.Range.AutoFilter Field:=11, Criteria1:="<>" & Key
            Lob.DataBodyRange.Delete
            Lob.AutoFilter.ShowAllData
                For Each cell In Lob.ListColumns(1).DataBodyRange
                    K = K + 1
                    cell.Value = K
                Next
                  
        End With
    'K?T QU? TB MVO AUDIT_DMS 25 T8.2020 _ ASM Bùi T?n Phúc
    dWb.Close True, sPath & "\KET QUA TB MVO AUDIT_DMS " & Ngay & ThangNam & "_ASM " & Key & ".xlsx"
Next
'******************************************************************************
Set Dic = Nothing
MsgBox "Hoan thanh " & J & " file!"
With Application
    .CopyObjectsWithCells = True
    .ScreenUpdating = True
    .DisplayAlerts = True
    .Calculation = xlCalculationAutomatic
End With
End Sub
Nhấp chuột vào đây để mở rộng...
Dạ em cảm ơn anh nhiều ạ <3
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

F
  • Question
Nhờ tư vấn cách tạo QR trong Excel
Trả lời
3
Đọc
342
fallheart82
F
C
Chia sẻ: Kết quả xổ số Keno
    • Cười
    • Thích
Trả lời
18
Đọc
392
ptm0412
ptm0412
nguyen trung cuong
File chứa marco không mở được.
Trả lời
2
Đọc
38
nguyen trung cuong
nguyen trung cuong
H
Hỗ trợ lấy danh sách dữ liệu thỏa mãn điều kiện
Trả lời
0
Đọc
1
Hoàng Kiên Anh
H
N
Vẽ biểu đồ kết hợp nhiều yếu tố trong excel
Trả lời
5
Đọc
140
hoangminhtien
hoangminhtien
20050911
File Excel lỗi ''The file could not be accessed. Try one of the following:.."
Trả lời
8
Đọc
287
nguyen trung cuong
nguyen trung cuong
Nhật Anh 9x
  • Question
Tính tồn cuối kỳ luỹ kế cho nhiều mã
Trả lời
0
Đọc
10
Nhật Anh 9x
Nhật Anh 9x
huynhnhu1234
Tìm giá vé máy bay một chiều và khứ hồi
Trả lời
1
Đọc
85
hvnhpro
H
nobita994
Trừ số lượng dần theo dòng khi quét Sumif tổng có tên sản phẩm bị trùng.
Trả lời
2
Đọc
40
bebo021999
B
PhanTuHuong
Bàn về môn thể thao bóng bàn nào!
    • Thích
    • Yêu thích
    • Cười
2
Trả lời
37
Đọc
2K
cantl
C
triplet123
GIÚP EM VỚI Ạ EM CẢM ƠN MỌI NGƯỜI NHIỀU Ạ
    • Phẫn nộ
Trả lời
2
Đọc
79
DeTong
D
Tuấn Bụng Bự
  • Question
Tìm Bộ 8 số xuất hiện nhiều nhất trong random( 1 - 80)
2
Trả lời
31
Đọc
781
Tuấn Bụng Bự
Tuấn Bụng Bự
S
  • Question
Xin file excel bảng giá quần áo, trang phục, phụ kiện
Trả lời
2
Đọc
55
VetMini
V
P
Tổng hợp dữ liệu từ các sheet theo chọn lọc
Trả lời
19
Đọc
359
VetMini
V
dung09031989
Xin giúp công thức tô màu các ô phía sau khi kế hoạch đặt hàng thiếu so với tồn kho.?
Trả lời
4
Đọc
139
VetMini
V
P
Nhờ giúp đỡ hàm lọc dữ liệu theo tỉnh
Trả lời
9
Đọc
134
VetMini
V
H
Tính và sắp xếp theo thư tự tăng dần có điều kiệu (có dữ liệu trùng nhau)
Trả lời
2
Đọc
74
longtay1111
L
nobita994
Trừ số lượng dần theo dòng khi quét Sumif tổng có tên sản phẩm bị trùng.
Trả lời
0
Đọc
56
nobita994
nobita994
kimtanmap
  • Question
Nhờ viết code VBA Macro lập lại.
Trả lời
6
Đọc
217
kimtanmap
kimtanmap
ongke0711
  • Question
Trộn dữ liệu từ Excel sang Word mở rộng (phiên bản ongke0711)
    • Thích
    • Yêu thích
    • Cảm ơn
11 12 13
Trả lời
257
Đọc
25K
Pham Ha 233
Pham Ha 233
Xem thêm…

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

Back
Top Bottom