COpy dữ liệu sang workbook mới theo nhiều điều kiện (1 người xem)

Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
I

iamhatinh

Thành viên mới
Tham gia
15/11/07
Bài viết
25
Được thích
2
tôi có 1 copy dữ liệu ở workbook hiện tại sang 1 workbook mới theo 1 số điều kiện như file đính kèm. Nhờ các bác giúp hộ, thanks
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
không cần ghi tên nhóm đằng sau
Còn số nhóm thì nhiều hơn chứ không cố định là 3
 
Lần chỉnh sửa cuối:
Upvote 0
iamhatinh đã viết:
tôi có 1 copy dữ liệu ở workbook hiện tại sang 1 workbook mới theo 1 số điều kiện như file đính kèm. Nhờ các bác giúp hộ, thanks
Nhấp chuột vào đây để mở rộng...
Mở File nhấn nút "TACH...", xem kết quả đã đúng ý chưa nhé! Có gì hồi âm lại cho tôi!
 

File đính kèm

Upvote 0
có 2 vấn đề
1. Nếu trên workbook không tồn tại 3 worksheet thì sẽ bị báo lỗi khi chạy ( và tên các worksheet như code của bạn bắt buộc phải đúng tên: Sheet2,Sheet3,Sheet4)
2.KHi tôi thay đổi dữ liệu nhóm mã tổ và chạy lại code thì dữ liệu không đúng
+ Khi tôi chạy lần 1 ( chưa thay đổi nhóm mã tổ);
8981.png


+ Khi thay đổi nhóm mã tổ và chạy lại
9672.png
 
Upvote 0
iamhatinh đã viết:
có 2 vấn đề
1. Nếu trên workbook không tồn tại 3 worksheet thì sẽ bị báo lỗi khi chạy ( và tên các worksheet như code của bạn bắt buộc phải đúng tên: Sheet2,Sheet3,Sheet4)
2.KHi tôi thay đổi dữ liệu nhóm mã tổ và chạy lại code thì dữ liệu không đúng
+ Khi tôi chạy lần 1 ( chưa thay đổi nhóm mã tổ);
8981.png


+ Khi thay đổi nhóm mã tổ và chạy lại
9672.png
Nhấp chuột vào đây để mở rộng...
Tôi chỉ viết code theo file mẫu bạn gửi. Muốn áp dụng vào file thật bạn phải túy biến cho phù hợp chứ. Mà bạn có biết nhiều về vba không? Liệu có sửa được code không?
 
Upvote 0
nhờ bạn sửa code hộ mình với vì mình cũng amateur về vba lắm ;)
 
Upvote 0
iamhatinh đã viết:
nhờ bạn sửa code hộ mình với vì mình cũng amateur về vba lắm ;)
Nhấp chuột vào đây để mở rộng...
Nếu không biết gì về VBA thì tôt hơn hết là gửi File thật nên để tôi làm giúp luôn cho. Nếu biết sửa hoặc tùy biến code thì mới đưa File file giả lập chứ. Nếu File bí mật sợ nhiều người biết thì gừi vào mail của tôi: chuot0106@gmail.com (nếu tin tưởng) còn không thì bạn tự làm vậy.
 
Upvote 0
Trong File bạn gửi cho tôi không có nhóm mã tổ à? Vậy căn cứ vào đâu để mà tách????
 
Upvote 0
các nhóm mã tổ được phân biệt với nhau bằng mỗi ô trống
8782.png


Như trên thì nhóm 1 là từ LLG200800001->LLG200800004, nhóm 2 là LLG200800005->LLG200800007,.......
 
Upvote 0
iamhatinh đã viết:
các nhóm mã tổ được phân biệt với nhau bằng mỗi ô trống
8782.png


Như trên thì nhóm 1 là từ LLG200800001->LLG200800004, nhóm 2 là LLG200800005->LLG200800007,.......
Nhấp chuột vào đây để mở rộng...
Nhưng trong file bạn gửi cho tôi đâu có nhóm tổ này? Bạn gửi lại file khác có kèm cả nhóm mã tổ nhé!
 
Upvote 0
iamhatinh đã viết:
các nhóm mã tổ được phân biệt với nhau bằng mỗi ô trống


Như trên thì nhóm 1 là từ LLG200800001->LLG200800004, nhóm 2 là LLG200800005->LLG200800007,.......
Nhấp chuột vào đây để mở rộng...
Tôi tưởng nhóm mã tổ phải cố định và biết trước chứ. Nếu không biết trước thì tôi không viết code được đâu. Điều kiện các nhóm mã tổ cách nhau 1 dòng trống như bạn nói chỉ có bạn mới hiểu chứ máy tính làm sao nó hiểu được. Thế nhóm mã tổ của bạn không cố định hay sao mà bạn không đưa nên được?
 
Upvote 0
iamhatinh đã viết:
tôi có 1 copy dữ liệu ở workbook hiện tại sang 1 workbook mới theo 1 số điều kiện như file đính kèm. Nhờ các bác giúp hộ, thanks
Nhấp chuột vào đây để mở rộng...
Bạn tải file đính kèm về chạy thử. Muốn thay đổi nhóm gì đó thì cứ thay đổi. Bài toán không khó nhưng cơ sở dữ liệu kỳ quá. Vì kỳ quá nên code dài lê thê. Các file mới tạo ra sẽ lưu trong cùng thư mục của file gốc. Các file trước đó cùng tên sẽ bị ghi đè.
PHP: 
Sub TachTach()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim GroupCode(), dataSource(), Temp(), kq(1 To 10000, 1 To 5)
Dim D1 As Object, D2 As Object, path As String, k, j, i, iTem
path = ThisWorkbook.path & "\"
Set D1 = CreateObject("scripting.dictionary")
Set D2 = CreateObject("scripting.dictionary")
With Sheets("data")
    dataSource = .Range(.[A2], .[E65536].End(3)).Value
End With
ReDim Temp(1 To UBound(dataSource), 1 To 6)
    With Sheets("GroupCode")
        GroupCode = .Range(.[A2], .[A65536].End(3)).Resize(, 2).Value
    End With
    For i = 1 To UBound(GroupCode)
        If GroupCode(i, 1) <> "" Then
            If GroupCode(i, 2) = "" Then
                GroupCode(i, 2) = GroupCode(i - 1, 2)
                If Not D1.exists(GroupCode(i, 1)) Then
                    D1.Add GroupCode(i, 1), GroupCode(i, 2)
                End If
                If Not D2.exists(GroupCode(i, 2)) Then
                    D2.Add GroupCode(i, 2), ""
                End If
            Else
                D1.Add GroupCode(i, 1), GroupCode(i, 2)
            End If
        End If
    Next
    ReDim Preserve dataSource(1 To UBound(dataSource), 1 To 6)
    For i = 1 To UBound(dataSource)
        If D1.exists(dataSource(i, 5)) Then
            dataSource(i, 6) = D1.iTem(dataSource(i, 5))
        End If
    Next
 For Each iTem In D2.keys
    For i = 1 To UBound(dataSource)
        If dataSource(i, 6) = iTem Then
            k = k + 1
            For j = 1 To 5
                kq(k, j) = dataSource(i, j)
            Next
        End If
    Next
    With Workbooks.Add
        .ActiveSheet.[A1].Resize(k, 5) = kq
        .SaveAs path & iTem, 51
        .Close
    End With
    k = 0
 Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Done"
End Sub
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
không hiểu sao khi chạy trên dữ liệu thật thì bị lỗi như hình:
(vùng dữ liệu của mình là từ cột A đến cột BN)

837error.png
 
Lần chỉnh sửa cuối:
Upvote 0
iamhatinh đã viết:
không hiểu sao khi chạy trên dữ liệu thật thì bị lỗi như hình:
Nhấp chuột vào đây để mở rộng...

Bạn phải tạo file có 2 sheet và tên sheet giống như file của mình thì code mới hoạt động được.
Cũng có thể file thật của bạn bố trí dữ liệu khác file mẫu. Không thấy file thì khó nói lắm
 
Lần chỉnh sửa cuối:
Upvote 0
chuot0106 đã viết:
Tôi tưởng nhóm mã tổ phải cố định và biết trước chứ. Nếu không biết trước thì tôi không viết code được đâu. Điều kiện các nhóm mã tổ cách nhau 1 dòng trống như bạn nói chỉ có bạn mới hiểu chứ máy tính làm sao nó hiểu được. Thế nhóm mã tổ của bạn không cố định hay sao mà bạn không đưa nên được?
Nhấp chuột vào đây để mở rộng...
Nhóm thứ nhất thì bạn biết lấy địa chỉ rồi. Giả sử bạn biết nhóm thứ n từ G10:G20 chẳng hạn, ô đầu tiên của nhóm n+1 là G22 hoặc range("G"& range("g20").end(xldown).row). Ô cuối nhóm này là range("g" & range("g22").end(xldown).row)
 
Upvote 0
iamhatinh đã viết:
mình up lại file rồi đó
https://www.dropbox.com/s/dkwo79azmu2by9b/gui_quanghai.xlsx
Nhấp chuột vào đây để mở rộng...
Bạn thay code này vào chắc là được. Nếu chưa được thì tính tiếp
PHP: 
Sub TachTach()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim GroupCode(), dataSource(), kq(1 To 10000, 1 To 65)
Dim D1 As Object, D2 As Object, path As String, k, j, i, iTem
path = ThisWorkbook.path & "\"
Set D1 = CreateObject("scripting.dictionary")
Set D2 = CreateObject("scripting.dictionary")
    With Sheets("data")
        dataSource = .Range(.[A2], .[BM65536].End(3)).Value
    End With
    With Sheets("GroupCode")
        GroupCode = .Range(.[A2], .[A65536].End(3)).Resize(, 2).Value
    End With
    For i = 1 To UBound(GroupCode)
        If GroupCode(i, 1) <> "" Then
            If GroupCode(i, 2) = "" Then
                GroupCode(i, 2) = GroupCode(i - 1, 2)
                If Not D1.exists(GroupCode(i, 1)) Then
                    D1.Add GroupCode(i, 1), GroupCode(i, 2)
                End If
                If Not D2.exists(GroupCode(i, 2)) Then
                    D2.Add GroupCode(i, 2), ""
                End If
            Else
                D1.Add GroupCode(i, 1), GroupCode(i, 2)
            End If
        End If
    Next
    ReDim Preserve dataSource(1 To UBound(dataSource), 1 To 66)
    For i = 1 To UBound(dataSource)
        If D1.exists(dataSource(i, 65)) Then
            dataSource(i, 66) = D1.iTem(dataSource(i, 65))
        End If
    Next
 For Each iTem In D2.keys
    For i = 1 To UBound(dataSource)
        If dataSource(i, 66) = iTem Then
            k = k + 1
            For j = 1 To 65
                kq(k, j) = dataSource(i, j)
            Next
        End If
    Next
    With Workbooks.Add
        .ActiveSheet.[A1].Resize(k, 65) = kq
        .SaveAs path & iTem, 51
        .Close
    End With
    k = 0
 Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Done"
End Sub
 
Upvote 0
quanghai1969 đã viết:
Bạn thay code này vào chắc là được. Nếu chưa được thì tính tiếp
PHP: 
Sub TachTach()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim GroupCode(), dataSource(), kq(1 To 10000, 1 To 65)
Dim D1 As Object, D2 As Object, path As String, k, j, i, iTem
path = ThisWorkbook.path & "\"
Set D1 = CreateObject("scripting.dictionary")
Set D2 = CreateObject("scripting.dictionary")
    With Sheets("data")
        dataSource = .Range(.[A2], .[BM65536].End(3)).Value
    End With
    With Sheets("GroupCode")
        GroupCode = .Range(.[A2], .[A65536].End(3)).Resize(, 2).Value
    End With
    For i = 1 To UBound(GroupCode)
        If GroupCode(i, 1) <> "" Then
            If GroupCode(i, 2) = "" Then
                GroupCode(i, 2) = GroupCode(i - 1, 2)
                If Not D1.exists(GroupCode(i, 1)) Then
                    D1.Add GroupCode(i, 1), GroupCode(i, 2)
                End If
                If Not D2.exists(GroupCode(i, 2)) Then
                    D2.Add GroupCode(i, 2), ""
                End If
            Else
                D1.Add GroupCode(i, 1), GroupCode(i, 2)
            End If
        End If
    Next
    ReDim Preserve dataSource(1 To UBound(dataSource), 1 To 66)
    For i = 1 To UBound(dataSource)
        If D1.exists(dataSource(i, 65)) Then
            dataSource(i, 66) = D1.iTem(dataSource(i, 65))
        End If
    Next
 For Each iTem In D2.keys
    For i = 1 To UBound(dataSource)
        If dataSource(i, 66) = iTem Then
            k = k + 1
            For j = 1 To 65
                kq(k, j) = dataSource(i, j)
            Next
        End If
    Next
    With Workbooks.Add
        .ActiveSheet.[A1].Resize(k, 65) = kq
        .SaveAs path & iTem, 51
        .Close
    End With
    k = 0
 Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Done"
End Sub
Nhấp chuột vào đây để mở rộng...
Em Test thử nhưng code vẫn báo lỗi, phiền anh xem giúp ạ!
 

File đính kèm

Upvote 0
cảm ơn bạn, code làm việc như đúng ý muốn của tôi :D
 
Upvote 0
iamhatinh đã viết:
http://www.giaiphapexcel.com/forum/...-sang-workbook-mới-theo-nhiều-điều-kiện/page3

Bạn cho mình hỏi thêm 1 tí trong code của bạn
Mình muốn để nguyên cả phần tiêu đề (header ) khi tách thành 3 nhóm mã tổ thì trong code của bạn sửa như thế nào ? cảm ơn !
Nhấp chuột vào đây để mở rộng...
Thêm cho bạn cái tiêu đề. Lưu ý đừng gởi tin riêng, cần gì cứ gởi trực tiếp lên diễn đàn sẽ có nhiều người giúp
PHP: 
Sub TachTach()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim GroupCode(), dataSource(), kq(1 To 10000, 1 To 65), tieude()
Dim D1 As Object, D2 As Object, path As String, k, j, i, iTem
path = ThisWorkbook.path & "\"
Set D1 = CreateObject("scripting.dictionary")
Set D2 = CreateObject("scripting.dictionary")
    With Sheets("data")
        dataSource = .Range(.[A2], .[BM65536].End(3)).Value
        tieude = .[A1:BM1].Value
    End With
    With Sheets("GroupCode")
        GroupCode = .Range(.[A2], .[A65536].End(3)).Resize(, 2).Value
    End With
    For i = 1 To UBound(GroupCode)
        If GroupCode(i, 1) <> "" Then
            If GroupCode(i, 2) = "" Then
                GroupCode(i, 2) = GroupCode(i - 1, 2)
                If Not D1.exists(GroupCode(i, 1)) Then
                    D1.Add GroupCode(i, 1), GroupCode(i, 2)
                End If
                If Not D2.exists(GroupCode(i, 2)) Then
                    D2.Add GroupCode(i, 2), ""
                End If
            Else
                D1.Add GroupCode(i, 1), GroupCode(i, 2)
            End If
        End If
    Next
    ReDim Preserve dataSource(1 To UBound(dataSource), 1 To 66)
    For i = 1 To UBound(dataSource)
        If D1.exists(dataSource(i, 65)) Then
            dataSource(i, 66) = D1.iTem(dataSource(i, 65))
        End If
    Next
 For Each iTem In D2.keys
    For i = 1 To UBound(dataSource)
        If dataSource(i, 66) = iTem Then
            k = k + 1
            For j = 1 To 65
                kq(k, j) = dataSource(i, j)
            Next
        End If
    Next
    With Workbooks.Add
        .ActiveSheet.[A1].Resize(, 65) = tieude
        .ActiveSheet.[A2].Resize(k, 65) = kq
        .SaveAs path & iTem, 51
        .Close
    End With
    k = 0
 Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Done"
End Sub
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

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

2
  • Question Question
Hỏi cách in phiếu điều tra PCGD-XMC từ file dữ liệu mẫu xuất ra từ hệ thống PCGD-XMC của Bộ GD (1 người xem)
    • Thích
Trả lời
23
Đọc
1K
Gà Công Nghệ
Gà Công Nghệ
V
Quản lý xuất nhập vật tư trong kho
Trả lời
7
Đọc
161
Vũ Hải Sơn
V
N
Tạo COM Add-In bằng Visual C++
    • Thích
Trả lời
11
Đọc
1K
Tuanba1992
Tuanba1992
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
    • Cảm ơn
3 4 5
Trả lời
425
Đọc
55K
Hoàng Tuấn 868
H
J
Xử lý các file Excel bị nặng sau nhiều năm sử dụng (1 người xem)
Trả lời
19
Đọc
2K
Hà Tiềm
H
Nguyễn Duy Tuân
PHƯƠNG PHÁP TRÍCH XUẤT NGƯỢC BÁO CÁO - Drilldown và Add-in A-Tools
    • Thích
Trả lời
1
Đọc
3K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
phuongnam366377
VbaTools – Bộ công cụ mở rộng cho VBA trong Excel
    • Thích
Trả lời
37
Đọc
911
YêuCN
Y
ptm0412
Hàm XLOOKUP: Có thể bạn chưa biết hết tính năng và ứng dụng
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
24
Đọc
15K
nguyen huu tai
N
H
Tổng hợp Công Nợ theo Công trình
Trả lời
47
Đọc
894
HangktGTN
H
queluatb
Tự động tăng số hóa đơn theo điều kiện
Trả lời
3
Đọc
85
HieuCD
H
Sơn Cận
Mẫu theo dõi hoạt động đội xe vận tải
Trả lời
0
Đọc
41
Sơn Cận
Sơn Cận
GPE-Trợ Lý
TALKSHOW 16 BẬT MÍ THỦ THUẬT GOOGLE SHEET: TỔNG HỢP DỮ LIỆU TỪ NHIỀU SHEET & FILE BĂNG IMPORTRANGE
Trả lời
0
Đọc
126
GPE-Trợ Lý
GPE-Trợ Lý
L
File Excel nặng chưa tìm được lý do ở đâu . Mong các bác hỗ trợ !
Trả lời
6
Đọc
315
huhumalu
H
D
Lỗi khi sử dụng Excel bị dính chuột trái ( chỉ dùng Excel mới bị )
Trả lời
14
Đọc
17K
SonXD85
S
thanhss
Tự động lấy dữ liệu từ các sheet khác đưa vào sheet tổng hợp khi chọn Ngày hoặc tháng hoặc năm
Trả lời
24
Đọc
618
thanhss
thanhss
D
nhờ các bác tạo giúp e một file ghi nhớ và nhắc ngày thu tiền ạ
    • Ngạc nhiên
    • Cười
Trả lời
0
Đọc
103
duongdaicb
D
B
Mình có làm đoạn code VBA trong file access mà cứ báo lỗi nhờ mọi người hướng dẫn
Trả lời
9
Đọc
303
baybley
B
L
  • Question Question
Gõ và chọn tên trong ComboBox hiển thị giá trị trong textbox
    • Cười
Trả lời
6
Đọc
248
huhumalu
H
H
Excel không lọc được toàn bộ dữ liệu
Trả lời
1
Đọc
148
yeudoi
yeudoi
U
VB tính tổng số cell trong 1 hàng có cùng màu với 1 cell so sánh ở cột khác
Trả lời
6
Đọc
225
yeudoi
yeudoi
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

Thời gian đếm ngược.

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom