Tách Sheet từ bảng khối lượng tạo phụ lục hợp đồng cho từng trạm (1 người xem)

  • Thread starter Thread starter quyenpv
  • Ngày gửi Ngày gửi
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)
quyenpv

quyenpv

Thu nhặt kiến thức
Tham gia
5/1/13
Bài viết
729
Được thích
97
Giới tính
Nam
Nghề nghiệp
Decode cuộc đời!
Em chào anh chị trên diễn đàn!
Lời đầu tiên chúc các anh chị mạnh khỏe, hạnh phúc
Lại một lần nữa em nhờ sự giúp đỡ của các anh chị trong việc tách Sheet từ bảng khối lượng tạo phụ lục hợp đồng cho từng trạm. Em diễn giải cụ thể như sau
- Trong file ban đầu sẽ có 2 Sheet là "PLHD" sẽ lấy tổng khối lượng từ Sheet "Khoiluong" và đơn giá trong Sheet "PLHD" đã được tính sẵn
- Sheet "Khoiluong" sẽ được phân tích bằng tay để tính được tổng khối lượng
Lưu ý: Số đầu việc trong Sheet "PLHD" và Số trạm trong Sheet "Khoiluong" có thể thay đổi tùy thuộc vào từng file
Các anh giúp đỡ em có thể tạo 1 Sheet "PLHD_All" và tách ra từng Sheet như file em đính kèm đã làm vì làm bằng tay số lượng ít thì không vấn đề gì nhưng khối lượng nhiều sẽ rất lâu và không tránh khỏi sai sót số liệu nên mạo muội mong các anh giúp đỡ em
Em cám ơn anh chị nhiều
Ảnh 1: Sheet "PLHD"
1632467912903.png

Ảnh 2: Sheet "Khoiluong"
1632467975827.png

Mong muốn
1. Tạo 1 Sheet tổng hợp toàn bộ
1632468032459.png
Và tách thành từng Sheet riêng biết dựa vào Sheet "Khoiluong" và đơn giá trong Sheet "PLHD"
1632468091022.png
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
Công thức tại sheet PLHD_All
E9=VLOOKUP("TỔNG HẠNG MỤC";INDIRECT("'"&B9&"'!$C:$G");5;0)/1,1
C9=INDIRECT("'"&B9&"'!$A$5")
Chỗ nào lỗi là do tên mã trạm tại cột B sheet PLHD_All không có tên sheet tương ứng.
 
Lần chỉnh sửa cuối:
Upvote 0
vu_tuan_manh_linh đã viết:
Công thức tại sheet PLHD_All, E9=VLOOKUP("TỔNG HẠNG MỤC";INDIRECT(B9&"!$C:$G");5;0)/1,1
Chỗ nào lỗi là do tên mã trạm tại cột B sheet PLHD_All không có tên sheet tương ứng.
Nhấp chuột vào đây để mở rộng...
Dạ đây là các Sheet đã được làm bằng tay sẵn ạ, với lại số lượng trạm và đầu việc có thể thay đổi nên em mong muốn có thể code VBA trong trường hợp tổng thể ạ
Vì hiện tại em đang làm theo kế hoạch này với hơn 300 vị trí sẽ rất lâu và có thể nhầm lẫn số liệu, mà dò từng trạm lại càng lâu hơn ạ
 
Upvote 0
quyenpv đã viết:
Dạ đây là các Sheet đã được làm bằng tay sẵn ạ, với lại số lượng trạm và đầu việc có thể thay đổi nên em mong muốn có thể code VBA trong trường hợp tổng thể ạ
Vì hiện tại em đang làm theo kế hoạch này với hơn 300 vị trí sẽ rất lâu và có thể nhầm lẫn số liệu, mà dò từng trạm lại càng lâu hơn ạ
Nhấp chuột vào đây để mở rộng...
VBA làm gì cho rắc rối! Mong là hiểu ý bạn. Với cấu trúc dữ liệu đồng bộ như này thì hàm cho nó lành!
 

File đính kèm

Upvote 0
vu_tuan_manh_linh đã viết:
VBA làm gì cho rắc rối! Mong là hiểu ý bạn. Với cấu trúc dữ liệu đồng bộ như này thì hàm cho nó lành!
Nhấp chuột vào đây để mở rộng...
Dạ cám ơn anh, kết quả thì đúng như ý mong muốn của em rồi anh
Tuy nhiên bộ phận tài chính lại yêu cầu phải có file in kết quả cho từng trạm mới quyết toán được nên tách Sheet là bắt buộc ạ
 
Upvote 0
quyenpv đã viết:
Dạ cám ơn anh, kết quả thì đúng như ý mong muốn của em rồi anh
Tuy nhiên bộ phận tài chính lại yêu cầu phải có file in kết quả cho từng trạm mới quyết toán được nên tách Sheet là bắt buộc ạ
Nhấp chuột vào đây để mở rộng...
Bạn nhìn sheet PLHD đi, cần mã trạm nào thì bạn chọn mã trạm đó. Yêu cầu của bộ phận tài chính là hơi khó hiểu, vì mục đích cuối cùng là có được số liệu họ cần cho từng trạm theo biểu mẫu mà họ mong muốn.
Nhân tiện đưa luôn cái hàm đọc số vào cho bạn. Khi chọn mã từng trạm ở PLHD thì nó đọc luôn số thành tiền tổng cho bạn.
 

File đính kèm

Upvote 0
Dạ cái họ bắt buộc là từng Sheet in ra đính kèm hồ sơ kiểu này anh

1632476793198.png
 
Upvote 0
quyenpv đã viết:
Dạ cái đó thì em biết ạ
Nhấp chuột vào đây để mở rộng...
Khi mọi người đưa ra đề nghị giải quyết vấn đề, chúng tôi, không hẳn là cứ nhao vào giải quyết theo đúng đề nghị của mọi người, vì đôi khi những mong muốn của mọi người đưa ra là chưa tối ưu, thậm chí có những chủ đề đi vào bế tắc phương án. Do đó, với kinh nghiệm, kiến thức chúng tôi có, chúng tôi thường sẽ đưa ra giải pháp tối ưu cho những lời đề nghị.
Nhiệm vụ của bạn bây giờ là "đấu tranh với những cái đầu tối cổ ở phòng tài chính".
 
Upvote 0
vu_tuan_manh_linh đã viết:
Khi mọi người đưa ra đề nghị giải quyết vấn đề, chúng tôi, không hẳn là cứ nhao vào giải quyết theo đúng đề nghị của mọi người, vì đôi khi những mong muốn của mọi người đưa ra là chưa tối ưu, thậm chí có những chủ đề đi vào bế tắc phương án. Do đó, với kinh nghiệm, kiến thức chúng tôi có, chúng tôi thường sẽ đưa ra giải pháp tối ưu cho những lời đề nghị.
Nhiệm vụ của bạn bây giờ là "đấu tranh với những cái đầu tối cổ ở phòng tài chính".
Nhấp chuột vào đây để mở rộng...
Khổ lắm anh ạ, làm đã vất vả mà vướng quyết toán càng khổ hơn.
 
Upvote 0
Em nhờ các anh chị!
Anh có thể chuyển sang VBA như mong muốn của em được không ạ. Mong các anh chị giúp đỡ
 
Lần chỉnh sửa cuối:
Upvote 0
Các anh chị giúp em với ạ, đôi khi anh chị thấy ngược đời nhưng lại là điều kiện bắt buộc như trường hợp của em ạ
 
Upvote 0
Nếu có thể anh cho tách từng Sheet giúp em với nhé anh SA_DQ
 
Upvote 0
vu_tuan_manh_linh đã viết:
Code không khó, tách sheet, tách thành file excel riêng biệt, tách thành file PDF ... làm được tuốt! Chỉ mỗi cái là thấy nó ... bất tiện.
Nhấp chuột vào đây để mở rộng...
Dạ em cũng không muốn thế anh, nhưng yêu cầu bắt buộc thế ạ. Tách Sheet có cái lợi trong khâu in ấn sẽ nhanh ạ
 
Upvote 0
quyenpv đã viết:
Các anh chị giúp em với ạ, đôi khi anh chị thấy ngược đời nhưng lại là điều kiện bắt buộc như trường hợp của em ạ
Nhấp chuột vào đây để mở rộng...
Bên bộ phận tài chính có lẽ nhiều người hay làm trên sheet để tiện nháp luôn trên sheet đó cộng trừ tính toán lại. Dù file có làm bài bản công thức cụ thể nhưng cứ đưa qua đó là họ cứ cộng trừ lại coi có sai sót gì không. Đây cũng là cách kiểm tra số liệu tuy rằng sẽ tốn thêm thời gian.
Nếu có tách sheet thì chắc lấy value đi cho họ ngồi mò lại công thức :D
 
Upvote 0
quyenpv đã viết:
Dạ em cũng không muốn thế anh, nhưng yêu cầu bắt buộc thế ạ. Tách Sheet có cái lợi trong khâu in ấn sẽ nhanh ạ
Nhấp chuột vào đây để mở rộng...
Nếu muốn in nhanh thì cho nó cái code in nữa là khỏi cần làm gì ngoài việc bấm 1 cái nút và ngồi lướt face.
Bài đã được tự động gộp:

qtm1987 đã viết:
Bên bộ phận tài chính có lẽ nhiều người hay làm trên sheet để tiện nháp luôn trên sheet đó cộng trừ tính toán lại. Dù file có làm bài bản công thức cụ thể nhưng cứ đưa qua đó là họ cứ cộng trừ lại coi có sai sót gì không. Đây cũng là cách kiểm tra số liệu tuy rằng sẽ tốn thêm thời gian.
Nếu có tách sheet thì chắc lấy value đi cho họ ngồi mò lại công thức :D
Nhấp chuột vào đây để mở rộng...
Hình như kế toán ở đâu cũng thế, họ chả tin công thức, họ chỉ tin vào các con số chết. Lọ mọ dò dẫm từng dòng.
 
Upvote 0
Bạn lấy cái này chép đè lên cái có trước:

PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
 Dim Rws As Long, J As Long, TT As Integer, W As Integer, Col As Integer
 Dim Rng As Range, sRng As Range, Arr()
 Dim MaTenCV As String
1 ' Tính Khôi Luong Công Viêc    '
 If Not Intersect(Target, [K3]) Is Nothing Then
    With Sheets("KhoiLuong")
        Rws = .[b999].End(xlUp).Row
        Set Rng = .Range(.[e3], .[e3].End(xlToRight))
        Set sRng = Rng.Find(Target.Value, , xlFormulas, xlWhole)
        If Not sRng Is Nothing Then
            ReDim a00(1 To Rws, 1 To 4):                ReDim aKQ(1 To Rws, 1 To 4)
            [A9].Resize(Rws, 9).ClearContents
            Col = sRng.Column
            For J = 4 To Rws
                If Len(.Cells(J, "B").Value) < 4 Then
                    W = W + 1:                  TT = 0
                    a00(W, 2) = .Cells(J, "B").Value:   a00(W, 3) = .Cells(J, "c").Value
                    aKQ(W, 1) = .Cells(J, Col).Value
                ElseIf Len(.Cells(J, "B").Value) >= 4 And .Cells(J, Col).Value > 0 Then
                    TT = TT + 1:                        W = W + 1
                    a00(W, 1) = TT:                     a00(W, 3) = .Cells(J, "c").Value
                    a00(W, 2) = .Cells(J, "B").Value:   a00(W, 4) = .Cells(J, "D").Value
                    aKQ(W, 1) = .Cells(J, Col).Value
                End If
            Next J
        End If
        [A9].Resize(W, 5).Value = a00()
    End With
2 ' Tính Don Giá Cho Tùng Mã Công Viêc       '
    With Sheets("PLHD")
        Rws = .[B9].CurrentRegion.Rows.Count
        Arr() = .[B9].Resize(Rws, 5).Value
        For J = 1 To UBound(Arr())
            MaTenCV = Arr(J, 1) & "@" & Arr(J, 2)
            For TT = 1 To UBound(a00())
                If MaTenCV = a00(TT, 2) & "@" & a00(TT, 3) Then
                    aKQ(TT, 2) = Arr(J, 5):             aKQ(TT, 3) = aKQ(TT, 1) * aKQ(TT, 2)
                End If
            Next TT
        Next J
    End With
    [F9].Resize(TT, 4).Value = aKQ()
    MsgBox "Xong Rôi!", , "GPE.COM Xin Chào!"
 End If
End Sub
 
Upvote 0
Dạ mong các anh giúp đỡ thực sự khổ lắm cãi nhau mãi mà vẫn không thể nào nói được với bộ phận tài chính đó ạ
Bài đã được tự động gộp:

SA_DQ đã viết:
Bạn lấy cái này chép đè lên cái có trước:

PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
 Dim Rws As Long, J As Long, TT As Integer, W As Integer, Col As Integer
 Dim Rng As Range, sRng As Range, Arr()
 Dim MaTenCV As String
1 ' Tính Khôi Luong Công Viêc    '
 If Not Intersect(Target, [K3]) Is Nothing Then
    With Sheets("KhoiLuong")
        Rws = .[b999].End(xlUp).Row
        Set Rng = .Range(.[e3], .[e3].End(xlToRight))
        Set sRng = Rng.Find(Target.Value, , xlFormulas, xlWhole)
        If Not sRng Is Nothing Then
            ReDim a00(1 To Rws, 1 To 4):                ReDim aKQ(1 To Rws, 1 To 4)
            [A9].Resize(Rws, 9).ClearContents
            Col = sRng.Column
            For J = 4 To Rws
                If Len(.Cells(J, "B").Value) < 4 Then
                    W = W + 1:                  TT = 0
                    a00(W, 2) = .Cells(J, "B").Value:   a00(W, 3) = .Cells(J, "c").Value
                    aKQ(W, 1) = .Cells(J, Col).Value
                ElseIf Len(.Cells(J, "B").Value) >= 4 And .Cells(J, Col).Value > 0 Then
                    TT = TT + 1:                        W = W + 1
                    a00(W, 1) = TT:                     a00(W, 3) = .Cells(J, "c").Value
                    a00(W, 2) = .Cells(J, "B").Value:   a00(W, 4) = .Cells(J, "D").Value
                    aKQ(W, 1) = .Cells(J, Col).Value
                End If
            Next J
        End If
        [A9].Resize(W, 5).Value = a00()
    End With
2 ' Tính Don Giá Cho Tùng Mã Công Viêc       '
    With Sheets("PLHD")
        Rws = .[B9].CurrentRegion.Rows.Count
        Arr() = .[B9].Resize(Rws, 5).Value
        For J = 1 To UBound(Arr())
            MaTenCV = Arr(J, 1) & "@" & Arr(J, 2)
            For TT = 1 To UBound(a00())
                If MaTenCV = a00(TT, 2) & "@" & a00(TT, 3) Then
                    aKQ(TT, 2) = Arr(J, 5):             aKQ(TT, 3) = aKQ(TT, 1) * aKQ(TT, 2)
                End If
            Next TT
        Next J
    End With
    [F9].Resize(TT, 4).Value = aKQ()
    MsgBox "Xong Rôi!", , "GPE.COM Xin Chào!"
 End If
End Sub
Nhấp chuột vào đây để mở rộng...
Dạ bị lỗi chỗ này anh
1632538336196.png
 
Upvote 0
Để khử các con số 0 & dòng cuối, bạn sửa dùm mình câu lệnh gần cuối thành

[F9].Resize(W, 4).Value = aKQ()
 
Upvote 0
SA_DQ đã viết:
Để khử các con số 0 & dòng cuối, bạn sửa dùm mình câu lệnh gần cuối thành

[F9].Resize(W, 4).Value = aKQ()
Nhấp chuột vào đây để mở rộng...
Trường hợp muốn đưa kết quả vào Sheet Tổng thì sao ạ, anh giúp em với
1632541731654.png
Bài đã được tự động gộp:

Trường hợp cột mã trạm trong Sheet "Khoiluong" mình có thể tạo luôn Name động được không anh không phải dùng thêm Sheet Phụ nữa ạ
 
Upvote 0
1./ Bạn muốn được số liệu trạm nào thì xào tổng của nó vô Sheet tổng, hay phải tính hết cho các trạm trong 1 lần?
2./ Tạo name động bạn hoàn toàn có thể thử; chuyện này có khi mình dỡ hơn bạn nữa là đằng khác!
3./ Nếu trong trang 'KhoiLuong' có cột đơn giá thì đỡ hơn bao nhiêu!

Chúc mọi người vui khỏe!
 
Upvote 0
SA_DQ đã viết:
1./ Bạn muốn được số liệu trạm nào thì xào tổng của nó vô Sheet tổng, hay phải tính hết cho các trạm trong 1 lần?
2./ Tạo name động bạn hoàn toàn có thể thử; chuyện này có khi mình dỡ hơn bạn nữa là đằng khác!
3./ Nếu trong trang 'KhoiLuong' có cột đơn giá thì đỡ hơn bao nhiêu!

Chúc mọi người vui khỏe!
Nhấp chuột vào đây để mở rộng...
1. Dạ tính hết trong 1 lần ạ, vừa tách Sheet và đưa giá trị ra Sheet Tổng ạ
2. Nếu tiện anh có thể đưa cột đơn giá sang Sheet Khoiluong ạ
 
Upvote 0
Các anh chị ơi, giúp em với nhé
:(:(:(:(:(:(
 
Upvote 0
Bạn kiểm theo file:
 

File đính kèm

Upvote 0
Thử lần nữa xem sao, hên sui nha!
 

File đính kèm

Upvote 0
Mã: 
Sub TongHopDuLieu()
 Dim Cls As Range, Rng As Range, sRng As Range, Arr(), Sh As Worksheet
 Dim Rws As Long, J As Long, W As Integer, Col As Integer, TT As Integer, Cot As Integer
 Dim MaTr As String, Tong As Double
 On Error GoTo LoiCT
 
 With Sheets("KhoiLuong")
    Rws = .[b999].End(xlUp).Row
    Set Rng = .Range(.[e3], .[e3].End(xlToRight))
    
    For Each Cls In Range([B9], [B9].End(xlDown))
        ReDim Arr(1 To Rws, 1 To 8):                        W = 0
        MaTr = Cls.Value:                                   Cls.Interior.ColorIndex = 2
        Set sRng = Rng.Find(MaTr, , xlFormulas, xlWhole)
        If Not sRng Is Nothing Then
            Col = sRng.Column:                              TT = 0
            W = 0
            For J = 4 To Rws                                'Duyêt Tìm Dòng Có Sô Liêu    '
                If Len(.Cells(J, "B").Value) < 4 Then
                    W = W + 1:
                    Arr(W, 2) = .Cells(J, "B").Value:       Arr(W, 3) = .Cells(J, "c").Value
                    If .Cells(J, "E").Value > 0 Then
                        Arr(W, 5) = .Cells(J, "E").Value    'Don Giá        '
                        Arr(W, 6) = .Cells(J, Col).Value:   Arr(W, 7) = Arr(W, 5) * Arr(W, 6)
                        Tong = Tong + Arr(W, 6)
                    End If
                End If
                If Len(.Cells(J, "B").Value) >= 4 And .Cells(J, Col).Value > 0 Then
                    TT = TT + 1:                            W = W + 1
                    Arr(W, 1) = TT:                         Arr(W, 2) = .Cells(J, "B").Value
                    Arr(W, 3) = .Cells(J, "c").Value:       Arr(W, 4) = .Cells(J, "D").Value
                    Arr(W, 5) = .Cells(J, "E").Value        'Don Giá        '
                    Arr(W, 6) = .Cells(J, Col).Value:       Arr(W, 7) = Arr(W, 5) * Arr(W, 6)
                    Tong = Tong + Arr(W, 6)
                End If
            Next J
        End If
        Set Sh = ThisWorkbook.Worksheets(MaTr)
        Sh.[A9].Resize(W, 8).Value = Arr()
        Erase Arr()
        If Tong > 0 Then
            Cells(Cls.Row, "I").Value = Sh.[G49].Value:     Tong = 0
        End If
    Next Cls
 End With
Err_:           Exit Sub
LoiCT:
    If Err = 9 Then
        Cls.Interior.ColorIndex = 38:
        Tong = 0:                                           Resume Next
    Else
        MsgBox Error:                                       GoTo Err_
    End If
End Sub

$$$$@ $$$$@ $$$$@ $$$$@ $$$$@ $$$$@
 
Upvote 0
Em xin lỗi chạy và kiểm tra thử các kiểu vẫn không ra được kết quả ạ
 
Upvote 0
:D :D :D :D :D :D :D :D :D :D :D :D :D :D :D :D :D :D :D :D
$$$$@
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
Trong file #36 có 4 hay 5 trang đã bị mình xóa trước đây & đã tô màu như hình của bạn; & khi chạy code trên file đó không báo lỗi, do mình đã có động tác khắc phục rồi;
Vậy nên mình chưa biết bạn xóa kiểu gì mà để lỗi làm vậy, chịu!
 
Upvote 0
SA_DQ đã viết:
Trong file #36 có 4 hay 5 trang đã bị mình xóa trước đây & đã tô màu như hình của bạn; & khi chạy code trên file đó không báo lỗi, do mình đã có động tác khắc phục rồi;
Vậy nên mình chưa biết bạn xóa kiểu gì mà để lỗi làm vậy, chịu!
Nhấp chuột vào đây để mở rộng...
Dạ vậy là sẽ dùng 2 code tại bài #36 và code Tonghopdulieu luôn hả anh
Với trường hợp code không tách Sheet như trên thì khó quá anh
 
Upvote 0
quyenpv đã viết:
(2) . . . . . vậy là sẽ dùng 2 code tại bài #36 và code Tonghopdulieu luôn hả anh
(1) Với trường hợp code không tách Sheet như trên thì khó quá anh
Nhấp chuột vào đây để mở rộng...
(1) Thì bạn thêm 1 động tác chép trang kết quả thu được về trang đúng tên của nó
Động tác này có thể nhờ ai đó viết thêm 1 hay 1 vài dòng lệnh nữa, bổ sung vô.

(2) Cũng được, tiện cái nào xài cái đó./.
 
Upvote 0
quyenpv đã viết:
Em chào anh chị trên diễn đàn!
Lời đầu tiên chúc các anh chị mạnh khỏe, hạnh phúc
Lại một lần nữa em nhờ sự giúp đỡ của các anh chị trong việc tách Sheet từ bảng khối lượng tạo phụ lục hợp đồng cho từng trạm. Em diễn giải cụ thể như sau
- Trong file ban đầu sẽ có 2 Sheet là "PLHD" sẽ lấy tổng khối lượng từ Sheet "Khoiluong" và đơn giá trong Sheet "PLHD" đã được tính sẵn
- Sheet "Khoiluong" sẽ được phân tích bằng tay để tính được tổng khối lượng
Lưu ý: Số đầu việc trong Sheet "PLHD" và Số trạm trong Sheet "Khoiluong" có thể thay đổi tùy thuộc vào từng file
Các anh giúp đỡ em có thể tạo 1 Sheet "PLHD_All" và tách ra từng Sheet như file em đính kèm đã làm vì làm bằng tay số lượng ít thì không vấn đề gì nhưng khối lượng nhiều sẽ rất lâu và không tránh khỏi sai sót số liệu nên mạo muội mong các anh giúp đỡ em
Em cám ơn anh chị nhiều
Nhấp chuột vào đây để mở rộng...
Sheet PLHD, nhập vào ô A5 "Công trình : Tối ưu, thu hồi thiết bị vô tuyến tại trạm #TRAM# theo 461/KH-KTTC"
Chạy sub main
Mã: 
Option Explicit
Sub Main()
  Call TangToc(True)
  Call Delete_OldSheet
  Call Create_NewSheet
  Call TangToc(False)
End Sub
Sub Create_NewSheet()
  Dim aKL(), aPLHD(), sArr(), res()
  Dim strTram$, shName$, strCT$, strTong$, Tong#, TongCong#
  Dim eRow&, sRow&, eCol&, sCol&, i&, j&, k&, iC&
 
  strCT = Sheets("PLHD").Range("A5").Value
  strTram = Mid(strCT, 52, 4)
  With Sheets("KhoiLuong")
    eCol = .Range("AAA3").End(xlToLeft).Column
    If eCol < 6 Then MsgBox ("Khong Co Tram Moi!"): Exit Sub
    aKL = .Range("A3", .Cells(.Range("A" & Rows.Count).End(xlUp).Row, eCol)).Value
  End With
  sRow = UBound(aKL)
  eRow = Sheets("PLHD").Range("C" & Rows.Count).End(xlUp).Row 'Dong Tien bang chu
  sCol = eCol - 5
  ReDim aPLHD(1 To sCol, 1 To 7)
  For j = 6 To eCol
    shName = aKL(1, j)
    k = k + 1
    aPLHD(k, 1) = k
    aPLHD(k, 2) = shName
    aPLHD(k, 3) = Replace(strCT, "#TRAM#", shName)
    aPLHD(k, 4) = strTram
    Sheets("PLHD").Copy after:=Sheets(Sheets.Count)
    With ActiveSheet
      .Name = shName
      .Range("A5").Value = aPLHD(k, 3)
      res = .Range("E8:G" & eRow).Value
      Tong = 0
      For i = 2 To UBound(res) - 1
        If aKL(i, 2) = "HM" Then
          iC = i 'Dong cong
        Else
          res(i, 1) = aKL(i, j)
          res(i, 3) = aKL(i, j) * res(i, 2)
          res(iC, 3) = res(iC, 3) + res(i, 3)
          Tong = Tong + res(i, 3)
        End If
      Next i
      res(UBound(res), 3) = Tong
      .Range("E8:G" & eRow).Value = res
      .Range("A" & eRow + 1).Value = "Tu nhap ham Add In doc so"
    End With
    aPLHD(k, 5) = Tong / 1.1
    aPLHD(k, 6) = Tong - aPLHD(k, 5)
    aPLHD(k, 7) = Tong
    TongCong = TongCong + Tong
  Next j
 
  With Sheets("PLHD_All")
    eRow = .Range("C" & Rows.Count).End(xlUp).Row
    strTong = .Range("C" & eRow).Value
    .Range("A10:H" & eRow).Clear
    .Range("A9").Resize(k, 7) = aPLHD
    .Range("A9:H9").Copy
    .Range("A9").Resize(k, 8).PasteSpecial (xlPasteFormats)
    .Range("C9").Offset(k) = strTong
    .Range("G9").Offset(k) = TongCong
  End With
End Sub
Sub Delete_OldSheet()
  Dim j&
  For j = Sheets.Count To 1 Step -1
    If Left(Sheets(j).Name, 3) = "VTU" Then Sheets(j).Delete
  Next j
End Sub
Sub TangToc(bChk As Boolean)
  Application.ScreenUpdating = Not bChk
  Application.EnableEvents = Not bChk
  Application.AskToUpdateLinks = Not bChk
  Application.DisplayAlerts = Not bChk
  If bChk Then Application.Calculation = xlCalculationAutomatic _
    Else Application.Calculation = xlCalculationManual
End Sub
 
Upvote 0
HieuCD đã viết:
Sheet PLHD, nhập vào ô A5 "Công trình : Tối ưu, thu hồi thiết bị vô tuyến tại trạm #TRAM# theo 461/KH-KTTC"
Chạy sub main
Mã: 
Option Explicit
Sub Main()
  Call TangToc(True)
  Call Delete_OldSheet
  Call Create_NewSheet
  Call TangToc(False)
End Sub
Sub Create_NewSheet()
  Dim aKL(), aPLHD(), sArr(), res()
  Dim strTram$, shName$, strCT$, strTong$, Tong#, TongCong#
  Dim eRow&, sRow&, eCol&, sCol&, i&, j&, k&, iC&
 
  strCT = Sheets("PLHD").Range("A5").Value
  strTram = Mid(strCT, 52, 4)
  With Sheets("KhoiLuong")
    eCol = .Range("AAA3").End(xlToLeft).Column
    If eCol < 6 Then MsgBox ("Khong Co Tram Moi!"): Exit Sub
    aKL = .Range("A3", .Cells(.Range("A" & Rows.Count).End(xlUp).Row, eCol)).Value
  End With
  sRow = UBound(aKL)
  eRow = Sheets("PLHD").Range("C" & Rows.Count).End(xlUp).Row 'Dong Tien bang chu
  sCol = eCol - 5
  ReDim aPLHD(1 To sCol, 1 To 7)
  For j = 6 To eCol
    shName = aKL(1, j)
    k = k + 1
    aPLHD(k, 1) = k
    aPLHD(k, 2) = shName
    aPLHD(k, 3) = Replace(strCT, "#TRAM#", shName)
    aPLHD(k, 4) = strTram
    Sheets("PLHD").Copy after:=Sheets(Sheets.Count)
    With ActiveSheet
      .Name = shName
      .Range("A5").Value = aPLHD(k, 3)
      res = .Range("E8:G" & eRow).Value
      Tong = 0
      For i = 2 To UBound(res) - 1
        If aKL(i, 2) = "HM" Then
          iC = i 'Dong cong
        Else
          res(i, 1) = aKL(i, j)
          res(i, 3) = aKL(i, j) * res(i, 2)
          res(iC, 3) = res(iC, 3) + res(i, 3)
          Tong = Tong + res(i, 3)
        End If
      Next i
      res(UBound(res), 3) = Tong
      .Range("E8:G" & eRow).Value = res
      .Range("A" & eRow + 1).Value = "Tu nhap ham Add In doc so"
    End With
    aPLHD(k, 5) = Tong / 1.1
    aPLHD(k, 6) = Tong - aPLHD(k, 5)
    aPLHD(k, 7) = Tong
    TongCong = TongCong + Tong
  Next j
 
  With Sheets("PLHD_All")
    eRow = .Range("C" & Rows.Count).End(xlUp).Row
    strTong = .Range("C" & eRow).Value
    .Range("A10:H" & eRow).Clear
    .Range("A9").Resize(k, 7) = aPLHD
    .Range("A9:H9").Copy
    .Range("A9").Resize(k, 8).PasteSpecial (xlPasteFormats)
    .Range("C9").Offset(k) = strTong
    .Range("G9").Offset(k) = TongCong
  End With
End Sub
Sub Delete_OldSheet()
  Dim j&
  For j = Sheets.Count To 1 Step -1
    If Left(Sheets(j).Name, 3) = "VTU" Then Sheets(j).Delete
  Next j
End Sub
Sub TangToc(bChk As Boolean)
  Application.ScreenUpdating = Not bChk
  Application.EnableEvents = Not bChk
  Application.AskToUpdateLinks = Not bChk
  Application.DisplayAlerts = Not bChk
  If bChk Then Application.Calculation = xlCalculationAutomatic _
    Else Application.Calculation = xlCalculationManual
End Sub
Nhấp chuột vào đây để mở rộng...
Cám ơn anh! Kết quả quá tuyệt vời hơn điều em mong muốn
 

File đính kèm

Upvote 0
quyenpv học thêm bên power Query đi. Trên youtube và diễn dàn mình có đó. MÌnh thấy rất hữu ít cho báo cáo số liệu của bạn. Bạn học thêm để số liệu của bạn chuẩn hơn, dễ thao tác và trích lục doanh thu theo tuần, ngày tháng nhanh hơn
 
Upvote 0
VTHANHSG đã viết:
quyenpv học thêm bên power Query đi. Trên youtube và diễn dàn mình có đó. MÌnh thấy rất hữu ít cho báo cáo số liệu của bạn. Bạn học thêm để số liệu của bạn chuẩn hơn, dễ thao tác và trích lục doanh thu theo tuần, ngày tháng nhanh hơn
Nhấp chuột vào đây để mở rộng...
Dạ cám ơn anh! Em cũng đang xem chưa làm được gì cả anh ạ
Cố gắng học mỗi ngày ạ
 
Upvote 0
quyenpv đã viết:
Cám ơn anh! Kết quả quá tuyệt vời hơn điều em mong muốn
Nhấp chuột vào đây để mở rộng...
Dear anh HieuCD
Code của anh chạy tuyệt vời rồi anh, có cách nào anh chỉnh giúp em chỉ lấy tên đầu việc có khối lượng trong Sheet "KhoiLuong" >0 được không anh. Vì hiện tại em đang làm bảng gộp nên nhiều trạm sẽ đầy đủ đầu việc nhiều trạm sẽ ít hơn, nếu code chỉnh lại được anh chỉnh giúp em với nhé
Cám ơn anh nhiều, chúc anh sức khỏe & hạnh phúc & thành công
 
Upvote 0
quyenpv đã viết:
Dear anh HieuCD
Code của anh chạy tuyệt vời rồi anh, có cách nào anh chỉnh giúp em chỉ lấy tên đầu việc có khối lượng trong Sheet "KhoiLuong" >0 được không anh. Vì hiện tại em đang làm bảng gộp nên nhiều trạm sẽ đầy đủ đầu việc nhiều trạm sẽ ít hơn, nếu code chỉnh lại được anh chỉnh giúp em với nhé
Cám ơn anh nhiều, chúc anh sức khỏe & hạnh phúc & thành công
Nhấp chuột vào đây để mở rộng...
Bạn tự viết thêm sub xóa các dòng có khối lượng =0
 
Upvote 0
Code chạy khá chậm, muốn nhanh chuyển qua dùng mảng
Mã: 
Option Explicit
Sub Main()
  Call TangToc(True)
  Sheets("PLHD_All").Activate
  Call Delete_OldSheet
  Call Create_NewSheet
  Call TangToc(False)
End Sub
Sub Create_NewSheet()
  Dim aKL(), aPLHD(), sArr(), res(), rng As Range
  Dim strTram$, shName$, strCT$, strTong$, Tong#, TongCong#
  Dim eRow&, sRow&, eCol&, sCol&, i&, j&, k&, iC&
 
  strCT = Sheets("PLHD").Range("A5").Value
  strTram = Mid(strCT, 52, 4)
  With Sheets("KhoiLuong")
    eCol = .Range("AAA3").End(xlToLeft).Column
    If eCol < 6 Then MsgBox ("Khong Co Tram Moi!"): Exit Sub
    aKL = .Range("A3", .Cells(.Range("A" & Rows.Count).End(xlUp).Row, eCol)).Value
  End With
  sRow = UBound(aKL)
  eRow = Sheets("PLHD").Range("C" & Rows.Count).End(xlUp).Row 'Dong Tien bang chu
  sCol = eCol - 5
  ReDim aPLHD(1 To sCol, 1 To 7)
  For j = 6 To eCol
    shName = aKL(1, j)
    k = k + 1
    aPLHD(k, 1) = k
    aPLHD(k, 2) = shName
    aPLHD(k, 3) = Replace(strCT, "#TRAM#", shName)
    aPLHD(k, 4) = strTram
    Sheets("PLHD").Copy after:=Sheets(Sheets.Count)
    With ActiveSheet
      .Name = shName
      .Range("A5").Value = aPLHD(k, 3)
      res = .Range("E8:G" & eRow).Value
      Tong = 0
      For i = 2 To UBound(res) - 1
        If aKL(i, 2) = "HM" Then
          iC = i 'Dong cong
        Else
          res(i, 1) = aKL(i, j)
          res(i, 3) = aKL(i, j) * res(i, 2)
          res(iC, 3) = res(iC, 3) + res(i, 3)
          Tong = Tong + res(i, 3)
        End If
      Next i
      res(UBound(res), 3) = Tong
      .Range("E8:G" & eRow).Value = res
      .Range("A" & eRow + 1).Value = "Tu nhap ham Add In doc so"
      Call Delete_Row(9, eRow) 'Xoa dong San Luong =0
    End With
    aPLHD(k, 5) = Tong / 1.1
    aPLHD(k, 6) = Tong - aPLHD(k, 5)
    aPLHD(k, 7) = Tong
    TongCong = TongCong + Tong
  Next j
 
  With Sheets("PLHD_All")
    eRow = .Range("C" & Rows.Count).End(xlUp).Row
    strTong = .Range("C" & eRow).Value
    .Range("A10:H" & eRow).Clear
    .Range("A9").Resize(k, 7) = aPLHD
    .Range("A9:H9").Copy
    .Range("A9").Resize(k, 8).PasteSpecial (xlPasteFormats)
    .Range("C9").Offset(k) = strTong
    .Range("G9").Offset(k) = TongCong
  End With
End Sub
Sub Delete_Row(ByRef fRow, ByRef eRow)
  Dim rng As Range, i&
  For i = fRow To eRow
      If Range("G" & i) = 0 Then
        If rng Is Nothing Then
          Set rng = Range("G" & i)
        Else
          Set rng = Union(rng, Range("G" & i))
        End If
      End If
  Next i
  If Not rng Is Nothing Then rng.EntireRow.Delete
End Sub
Sub Delete_OldSheet()
  Dim j&, a$
  For j = Sheets.Count To 1 Step -1
    a = Left(Sheets(j).Name, 3)
    If Left(Sheets(j).Name, 3) = "VTU" Then Sheets(j).Delete
  Next j
End Sub
Sub TangToc(bChk As Boolean)
  Application.ScreenUpdating = Not bChk
  Application.EnableEvents = Not bChk
  Application.AskToUpdateLinks = Not bChk
  Application.DisplayAlerts = Not bChk
  If bChk Then Application.Calculation = xlCalculationAutomatic _
    Else Application.Calculation = xlCalculationManual
End Sub
 
Upvote 0
HieuCD đã viết:
Code chạy khá chậm, muốn nhanh chuyển qua dùng mảng
Mã: 
Option Explicit
Sub Main()
  Call TangToc(True)
  Sheets("PLHD_All").Activate
  Call Delete_OldSheet
  Call Create_NewSheet
  Call TangToc(False)
End Sub
Sub Create_NewSheet()
  Dim aKL(), aPLHD(), sArr(), res(), rng As Range
  Dim strTram$, shName$, strCT$, strTong$, Tong#, TongCong#
  Dim eRow&, sRow&, eCol&, sCol&, i&, j&, k&, iC&
 
  strCT = Sheets("PLHD").Range("A5").Value
  strTram = Mid(strCT, 52, 4)
  With Sheets("KhoiLuong")
    eCol = .Range("AAA3").End(xlToLeft).Column
    If eCol < 6 Then MsgBox ("Khong Co Tram Moi!"): Exit Sub
    aKL = .Range("A3", .Cells(.Range("A" & Rows.Count).End(xlUp).Row, eCol)).Value
  End With
  sRow = UBound(aKL)
  eRow = Sheets("PLHD").Range("C" & Rows.Count).End(xlUp).Row 'Dong Tien bang chu
  sCol = eCol - 5
  ReDim aPLHD(1 To sCol, 1 To 7)
  For j = 6 To eCol
    shName = aKL(1, j)
    k = k + 1
    aPLHD(k, 1) = k
    aPLHD(k, 2) = shName
    aPLHD(k, 3) = Replace(strCT, "#TRAM#", shName)
    aPLHD(k, 4) = strTram
    Sheets("PLHD").Copy after:=Sheets(Sheets.Count)
    With ActiveSheet
      .Name = shName
      .Range("A5").Value = aPLHD(k, 3)
      res = .Range("E8:G" & eRow).Value
      Tong = 0
      For i = 2 To UBound(res) - 1
        If aKL(i, 2) = "HM" Then
          iC = i 'Dong cong
        Else
          res(i, 1) = aKL(i, j)
          res(i, 3) = aKL(i, j) * res(i, 2)
          res(iC, 3) = res(iC, 3) + res(i, 3)
          Tong = Tong + res(i, 3)
        End If
      Next i
      res(UBound(res), 3) = Tong
      .Range("E8:G" & eRow).Value = res
      .Range("A" & eRow + 1).Value = "Tu nhap ham Add In doc so"
      Call Delete_Row(9, eRow) 'Xoa dong San Luong =0
    End With
    aPLHD(k, 5) = Tong / 1.1
    aPLHD(k, 6) = Tong - aPLHD(k, 5)
    aPLHD(k, 7) = Tong
    TongCong = TongCong + Tong
  Next j
 
  With Sheets("PLHD_All")
    eRow = .Range("C" & Rows.Count).End(xlUp).Row
    strTong = .Range("C" & eRow).Value
    .Range("A10:H" & eRow).Clear
    .Range("A9").Resize(k, 7) = aPLHD
    .Range("A9:H9").Copy
    .Range("A9").Resize(k, 8).PasteSpecial (xlPasteFormats)
    .Range("C9").Offset(k) = strTong
    .Range("G9").Offset(k) = TongCong
  End With
End Sub
Sub Delete_Row(ByRef fRow, ByRef eRow)
  Dim rng As Range, i&
  For i = fRow To eRow
      If Range("G" & i) = 0 Then
        If rng Is Nothing Then
          Set rng = Range("G" & i)
        Else
          Set rng = Union(rng, Range("G" & i))
        End If
      End If
  Next i
  If Not rng Is Nothing Then rng.EntireRow.Delete
End Sub
Sub Delete_OldSheet()
  Dim j&, a$
  For j = Sheets.Count To 1 Step -1
    a = Left(Sheets(j).Name, 3)
    If Left(Sheets(j).Name, 3) = "VTU" Then Sheets(j).Delete
  Next j
End Sub
Sub TangToc(bChk As Boolean)
  Application.ScreenUpdating = Not bChk
  Application.EnableEvents = Not bChk
  Application.AskToUpdateLinks = Not bChk
  Application.DisplayAlerts = Not bChk
  If bChk Then Application.Calculation = xlCalculationAutomatic _
    Else Application.Calculation = xlCalculationManual
End Sub
Nhấp chuột vào đây để mở rộng...
Dạ cám ơn anh
Dùng kiểu nào cũng được miễn sao chạy nhanh và tối ưu nhất ạ.
 
Upvote 0
quyenpv đã viết:
Dạ cám ơn anh
Dùng kiểu nào cũng được miễn sao chạy nhanh và tối ưu nhất ạ.
Nhấp chuột vào đây để mở rộng...
Thử code mới xem có nhanh hơn không
Mã: 
Option Explicit
Sub Main2()
  Dim aKL(), eCol&

  With Sheets("KhoiLuong")
    eCol = .Range("AAA3").End(xlToLeft).Column
    If eCol < 6 Then MsgBox ("Khong Co Tram Moi!"): Exit Sub
    aKL = .Range("A3", .Cells(.Range("A" & Rows.Count).End(xlUp).Row, eCol)).Value
  End With
  Call TangToc(True)
  Call CreateSheet_VTU(aKL)
  Call Create_Res(aKL)
  Call TangToc(False)
End Sub

Sub Create_Res(aKL)
  Dim aDonGia(), aPLHD(), sArr(), res(), rng As Range, rngFM As Range
  Dim strTHM$, shName$, strTong$, Tong#, TongCong#
  Dim eRow&, sRow&, sCol&, i&, j&, k&, stt&, r&, ik&
 
  sRow = UBound(aKL): sCol = UBound(aKL, 2)
  aDonGia = Sheets("PLHD").Range("F8").Resize(sRow + 1).Value
  Set rng = Sheets("PLHD").Range("A9:H9").Offset(sRow + 1)
  Set rngFM = Sheets("PLHD").Range("A10:H10")
  strTHM = Sheets("PLHD").Range("C8").Offset(sRow)
  ReDim aPLHD(1 To sCol - 5, 1 To 8)
 
  For j = 6 To sCol
    ReDim res(1 To sRow + 1, 1 To 8)
    k = 0: Tong = 0: stt = 1
    For i = 2 To sRow
      If aKL(i, 2) = "HM" Then
        If stt > 0 Then k = k + 1
        ik = k
        stt = 0
        res(k, 2) = aKL(i, 2):    res(k, 3) = aKL(i, 3)
      ElseIf aKL(i, j) > 0 Then
        k = k + 1
        stt = stt + 1
        res(k, 1) = stt:          res(k, 2) = aKL(i, 2)
        res(k, 3) = aKL(i, 3):    res(k, 4) = aKL(i, 4)
        res(k, 5) = aKL(i, j):    res(k, 6) = aDonGia(i, 1)
        res(k, 7) = res(k, 5) * res(k, 6)
        res(ik, 7) = res(ik, 7) + res(k, 7)
        Tong = Tong + res(k, 7)
      End If
    Next i
    If k Then
      res(k + 1, 3) = strTHM: res(k + 1, 7) = Tong
      With Sheets(aKL(1, j))
        .Range("A9").Resize(k + 1, 7).Value = res
        eRow = .Range("C" & Rows.Count).End(xlUp).Row
        .Range("A" & eRow + 1).Value = "Tu nhap ham Add In doc so"
        rng.Copy .Range("A" & eRow + 2)
        rngFM.Copy
        .Range("A9").Resize(k + 1, 8).PasteSpecial (xlPasteFormats)
      End With
      r = r + 1
      aPLHD(r, 1) = r
      aPLHD(r, 2) = aKL(1, j)
      aPLHD(r, 3) = Sheets(aKL(1, j)).Range("A5").Value
      aPLHD(r, 4) = "tram"
      aPLHD(r, 5) = Tong / 1.1
      aPLHD(r, 6) = Tong - aPLHD(k, 5)
      aPLHD(r, 7) = Tong
      TongCong = TongCong + Tong
    End If
  Next j
 
  With Sheets("PLHD_All")
    eRow = .Range("C" & Rows.Count).End(xlUp).Row
    strTong = .Range("C" & eRow).Value
    If eRow > 9 Then .Range("A10:H" & eRow).Clear
    .Range("A9").Resize(r, 7) = aPLHD
    .Range("A9:H9").Copy
    .Range("A9").Resize(r, 8).PasteSpecial (xlPasteFormats)
    .Range("C9").Offset(r) = strTong
    .Range("G9").Offset(r) = TongCong
  End With
End Sub

Sub CreateSheet_VTU(ByRef aKL)
  Dim j&, eRow&, strCT$, shName, dic As Object
 
  If Left(ActiveSheet.Name, 3) = "VTU" Then Sheets("PLHD_All").Activate
  Set dic = CreateObject("scripting.dictionary")
  For j = 6 To UBound(aKL, 2)
    If aKL(1, j) <> Empty Then dic.Item(aKL(1, j)) = ""
  Next j
  For j = Sheets.Count To 1 Step -1
    shName = Sheets(j).Name
    If Left(Sheets(shName).Name, 3) = "VTU" Then
      If dic.exists(shName) Then
        eRow = Sheets(shName).Range("A" & Rows.Count).End(xlUp).Row
        If eRow > 8 Then Sheets(shName).Range("A9:H" & eRow).Clear
        dic.Remove (shName)
      Else
        Sheets(shName).Delete
      End If
    End If
  Next j
  If dic.Count > 0 Then
    strCT = Sheets("PLHD").Range("A5").Value
    eRow = Sheets("PLHD").Range("A" & Rows.Count).End(xlUp).Row
    For Each shName In dic.keys
      Sheets("PLHD").Copy after:=Sheets(Sheets.Count)
      With ActiveSheet
        .Name = shName
        .Range("A5").Value = Replace(strCT, "#TRAM#", shName)
        .Range("A9:H" & eRow).Clear
      End With
    Next shName
  End If
  Set dic = Nothing
End Sub

Sub TangToc(bChk As Boolean)
  Application.ScreenUpdating = Not bChk
  Application.EnableEvents = Not bChk
  Application.AskToUpdateLinks = Not bChk
  Application.DisplayAlerts = Not bChk
  If bChk Then Application.Calculation = xlCalculationAutomatic _
    Else Application.Calculation = xlCalculationManual
End Sub
 
Upvote 0
HieuCD đã viết:
Thử code mới xem có nhanh hơn không
Mã: 
Option Explicit
Sub Main2()
  Dim aKL(), eCol&

  With Sheets("KhoiLuong")
    eCol = .Range("AAA3").End(xlToLeft).Column
    If eCol < 6 Then MsgBox ("Khong Co Tram Moi!"): Exit Sub
    aKL = .Range("A3", .Cells(.Range("A" & Rows.Count).End(xlUp).Row, eCol)).Value
  End With
  Call TangToc(True)
  Call CreateSheet_VTU(aKL)
  Call Create_Res(aKL)
  Call TangToc(False)
End Sub

Sub Create_Res(aKL)
  Dim aDonGia(), aPLHD(), sArr(), res(), rng As Range, rngFM As Range
  Dim strTHM$, shName$, strTong$, Tong#, TongCong#
  Dim eRow&, sRow&, sCol&, i&, j&, k&, stt&, r&, ik&
 
  sRow = UBound(aKL): sCol = UBound(aKL, 2)
  aDonGia = Sheets("PLHD").Range("F8").Resize(sRow + 1).Value
  Set rng = Sheets("PLHD").Range("A9:H9").Offset(sRow + 1)
  Set rngFM = Sheets("PLHD").Range("A10:H10")
  strTHM = Sheets("PLHD").Range("C8").Offset(sRow)
  ReDim aPLHD(1 To sCol - 5, 1 To 8)
 
  For j = 6 To sCol
    ReDim res(1 To sRow + 1, 1 To 8)
    k = 0: Tong = 0: stt = 1
    For i = 2 To sRow
      If aKL(i, 2) = "HM" Then
        If stt > 0 Then k = k + 1
        ik = k
        stt = 0
        res(k, 2) = aKL(i, 2):    res(k, 3) = aKL(i, 3)
      ElseIf aKL(i, j) > 0 Then
        k = k + 1
        stt = stt + 1
        res(k, 1) = stt:          res(k, 2) = aKL(i, 2)
        res(k, 3) = aKL(i, 3):    res(k, 4) = aKL(i, 4)
        res(k, 5) = aKL(i, j):    res(k, 6) = aDonGia(i, 1)
        res(k, 7) = res(k, 5) * res(k, 6)
        res(ik, 7) = res(ik, 7) + res(k, 7)
        Tong = Tong + res(k, 7)
      End If
    Next i
    If k Then
      res(k + 1, 3) = strTHM: res(k + 1, 7) = Tong
      With Sheets(aKL(1, j))
        .Range("A9").Resize(k + 1, 7).Value = res
        eRow = .Range("C" & Rows.Count).End(xlUp).Row
        .Range("A" & eRow + 1).Value = "Tu nhap ham Add In doc so"
        rng.Copy .Range("A" & eRow + 2)
        rngFM.Copy
        .Range("A9").Resize(k + 1, 8).PasteSpecial (xlPasteFormats)
      End With
      r = r + 1
      aPLHD(r, 1) = r
      aPLHD(r, 2) = aKL(1, j)
      aPLHD(r, 3) = Sheets(aKL(1, j)).Range("A5").Value
      aPLHD(r, 4) = "tram"
      aPLHD(r, 5) = Tong / 1.1
      aPLHD(r, 6) = Tong - aPLHD(k, 5)
      aPLHD(r, 7) = Tong
      TongCong = TongCong + Tong
    End If
  Next j
 
  With Sheets("PLHD_All")
    eRow = .Range("C" & Rows.Count).End(xlUp).Row
    strTong = .Range("C" & eRow).Value
    If eRow > 9 Then .Range("A10:H" & eRow).Clear
    .Range("A9").Resize(r, 7) = aPLHD
    .Range("A9:H9").Copy
    .Range("A9").Resize(r, 8).PasteSpecial (xlPasteFormats)
    .Range("C9").Offset(r) = strTong
    .Range("G9").Offset(r) = TongCong
  End With
End Sub

Sub CreateSheet_VTU(ByRef aKL)
  Dim j&, eRow&, strCT$, shName, dic As Object
 
  If Left(ActiveSheet.Name, 3) = "VTU" Then Sheets("PLHD_All").Activate
  Set dic = CreateObject("scripting.dictionary")
  For j = 6 To UBound(aKL, 2)
    If aKL(1, j) <> Empty Then dic.Item(aKL(1, j)) = ""
  Next j
  For j = Sheets.Count To 1 Step -1
    shName = Sheets(j).Name
    If Left(Sheets(shName).Name, 3) = "VTU" Then
      If dic.exists(shName) Then
        eRow = Sheets(shName).Range("A" & Rows.Count).End(xlUp).Row
        If eRow > 8 Then Sheets(shName).Range("A9:H" & eRow).Clear
        dic.Remove (shName)
      Else
        Sheets(shName).Delete
      End If
    End If
  Next j
  If dic.Count > 0 Then
    strCT = Sheets("PLHD").Range("A5").Value
    eRow = Sheets("PLHD").Range("A" & Rows.Count).End(xlUp).Row
    For Each shName In dic.keys
      Sheets("PLHD").Copy after:=Sheets(Sheets.Count)
      With ActiveSheet
        .Name = shName
        .Range("A5").Value = Replace(strCT, "#TRAM#", shName)
        .Range("A9:H" & eRow).Clear
      End With
    Next shName
  End If
  Set dic = Nothing
End Sub

Sub TangToc(bChk As Boolean)
  Application.ScreenUpdating = Not bChk
  Application.EnableEvents = Not bChk
  Application.AskToUpdateLinks = Not bChk
  Application.DisplayAlerts = Not bChk
  If bChk Then Application.Calculation = xlCalculationAutomatic _
    Else Application.Calculation = xlCalculationManual
End Sub
Nhấp chuột vào đây để mở rộng...
Úi siêu nhanh, nhanh hơn Code trước nhiều anh ạ. Em đang kiếm code đo thời gian trên diễn đàn để kiểm tra chính xác ạ
Cám ơn anh rất nhiều ạ
 
Upvote 0
Anh Hiếu kiểm tra giúp em chỗ này với nhé
Trường hợp mã trạm có nhưng không có khối lượng trong Sheet PLHD_All vẫn tính giá tiền anh
1633507127253.png
 
Upvote 0
Dạ trong bảng PLHD_All đã loại bỏ được VTU199 do không có khối lượng. Tuy nhiên trong bảng đó có rất nhiều cột có giá trị âm ạ
 
Upvote 0
quyenpv đã viết:
Dạ trong bảng PLHD_All đã loại bỏ được VTU199 do không có khối lượng. Tuy nhiên trong bảng đó có rất nhiều cột có giá trị âm ạ
Nhấp chuột vào đây để mở rộng...
Chỉnh lại
aPLHD(r, 6) = Tong - aPLHD(r, 5)
Mã: 
Sub Create_Res(aKL)
  Dim aDonGia(), aPLHD(), sArr(), res(), rng As Range, rngFM As Range
  Dim strTHM$, shName$, strTong$, Tong#, TongCong#
  Dim eRow&, sRow&, sCol&, i&, j&, k&, stt&, r&, ik&
 
  sRow = UBound(aKL): sCol = UBound(aKL, 2)
  aDonGia = Sheets("PLHD").Range("F8").Resize(sRow + 1).Value
  Set rng = Sheets("PLHD").Range("A9:H9").Offset(sRow + 1)
  Set rngFM = Sheets("PLHD").Range("A10:H10")
  strTHM = Sheets("PLHD").Range("C8").Offset(sRow)
  ReDim aPLHD(1 To sCol - 5, 1 To 8)
 
  For j = 6 To sCol
If aKL(1, j) = "VTU0190-11" Then
i = 1
End If
    ReDim res(1 To sRow + 1, 1 To 8)
    k = 0: Tong = 0: stt = 1
    For i = 2 To sRow
      If aKL(i, 2) = "HM" Then
        If stt > 0 Then k = k + 1
        ik = k
        stt = 0
        res(k, 2) = aKL(i, 2):    res(k, 3) = aKL(i, 3)
      ElseIf aKL(i, j) > 0 Then
        k = k + 1
        stt = stt + 1
        res(k, 1) = stt:          res(k, 2) = aKL(i, 2)
        res(k, 3) = aKL(i, 3):    res(k, 4) = aKL(i, 4)
        res(k, 5) = aKL(i, j):    res(k, 6) = aDonGia(i, 1)
        res(k, 7) = res(k, 5) * res(k, 6)
        res(ik, 7) = res(ik, 7) + res(k, 7)
        Tong = Tong + res(k, 7)
      End If
    Next i
    If Tong > 0 Then
      res(k + 1, 3) = strTHM: res(k + 1, 7) = Tong
      With Sheets(aKL(1, j))
        .Range("A9").Resize(k + 1, 7).Value = res
        eRow = .Range("C" & Rows.Count).End(xlUp).Row
        .Range("A" & eRow + 1).Value = "Tu nhap ham Add In doc so"
        rng.Copy .Range("A" & eRow + 2)
        rngFM.Copy
        .Range("A9").Resize(k + 1, 8).PasteSpecial (xlPasteFormats)
      End With
      r = r + 1
      aPLHD(r, 1) = r
      aPLHD(r, 2) = aKL(1, j)
      aPLHD(r, 3) = Sheets(aKL(1, j)).Range("A5").Value
      aPLHD(r, 4) = "tram"
      aPLHD(r, 5) = Tong / 1.1
      aPLHD(r, 6) = Tong - aPLHD(r, 5)
      aPLHD(r, 7) = Tong
      TongCong = TongCong + Tong
    End If
  Next j
 
  With Sheets("PLHD_All")
    eRow = .Range("C" & Rows.Count).End(xlUp).Row
    strTong = .Range("C" & eRow).Value
    If eRow > 9 Then .Range("A10:H" & eRow).Clear
    .Range("A9").Resize(r, 7) = aPLHD
    .Range("A9:H9").Copy
    .Range("A9").Resize(r, 8).PasteSpecial (xlPasteFormats)
    .Range("C9").Offset(r) = strTong
    .Range("G9").Offset(r) = TongCong
  End With
End Sub
 
Upvote 0
HieuCD đã viết:
Chỉnh lại
aPLHD(r, 6) = Tong - aPLHD(r, 5)
Mã: 
Sub Create_Res(aKL)
  Dim aDonGia(), aPLHD(), sArr(), res(), rng As Range, rngFM As Range
  Dim strTHM$, shName$, strTong$, Tong#, TongCong#
  Dim eRow&, sRow&, sCol&, i&, j&, k&, stt&, r&, ik&
 
  sRow = UBound(aKL): sCol = UBound(aKL, 2)
  aDonGia = Sheets("PLHD").Range("F8").Resize(sRow + 1).Value
  Set rng = Sheets("PLHD").Range("A9:H9").Offset(sRow + 1)
  Set rngFM = Sheets("PLHD").Range("A10:H10")
  strTHM = Sheets("PLHD").Range("C8").Offset(sRow)
  ReDim aPLHD(1 To sCol - 5, 1 To 8)
 
  For j = 6 To sCol
If aKL(1, j) = "VTU0190-11" Then
i = 1
End If
    ReDim res(1 To sRow + 1, 1 To 8)
    k = 0: Tong = 0: stt = 1
    For i = 2 To sRow
      If aKL(i, 2) = "HM" Then
        If stt > 0 Then k = k + 1
        ik = k
        stt = 0
        res(k, 2) = aKL(i, 2):    res(k, 3) = aKL(i, 3)
      ElseIf aKL(i, j) > 0 Then
        k = k + 1
        stt = stt + 1
        res(k, 1) = stt:          res(k, 2) = aKL(i, 2)
        res(k, 3) = aKL(i, 3):    res(k, 4) = aKL(i, 4)
        res(k, 5) = aKL(i, j):    res(k, 6) = aDonGia(i, 1)
        res(k, 7) = res(k, 5) * res(k, 6)
        res(ik, 7) = res(ik, 7) + res(k, 7)
        Tong = Tong + res(k, 7)
      End If
    Next i
    If Tong > 0 Then
      res(k + 1, 3) = strTHM: res(k + 1, 7) = Tong
      With Sheets(aKL(1, j))
        .Range("A9").Resize(k + 1, 7).Value = res
        eRow = .Range("C" & Rows.Count).End(xlUp).Row
        .Range("A" & eRow + 1).Value = "Tu nhap ham Add In doc so"
        rng.Copy .Range("A" & eRow + 2)
        rngFM.Copy
        .Range("A9").Resize(k + 1, 8).PasteSpecial (xlPasteFormats)
      End With
      r = r + 1
      aPLHD(r, 1) = r
      aPLHD(r, 2) = aKL(1, j)
      aPLHD(r, 3) = Sheets(aKL(1, j)).Range("A5").Value
      aPLHD(r, 4) = "tram"
      aPLHD(r, 5) = Tong / 1.1
      aPLHD(r, 6) = Tong - aPLHD(r, 5)
      aPLHD(r, 7) = Tong
      TongCong = TongCong + Tong
    End If
  Next j
 
  With Sheets("PLHD_All")
    eRow = .Range("C" & Rows.Count).End(xlUp).Row
    strTong = .Range("C" & eRow).Value
    If eRow > 9 Then .Range("A10:H" & eRow).Clear
    .Range("A9").Resize(r, 7) = aPLHD
    .Range("A9:H9").Copy
    .Range("A9").Resize(r, 8).PasteSpecial (xlPasteFormats)
    .Range("C9").Offset(r) = strTong
    .Range("G9").Offset(r) = TongCong
  End With
End Sub
Nhấp chuột vào đây để mở rộng...
Dạ Code đúng rồi anh
Trường hợp khối lượng trạm đó =0 không cần tạo Sheet VTU riêng nhưng trong bảng tổng hợp PLHA_All vẫn để mã trạm đó và cột giá trị để =0 thì cần chỉnh đoạn này đúng không ạ
Sub Create_Res(aKL), chỉnh lệnh
If Tong > 0 Then
Thành
If k Then

Và đoạn này có tác dụng gì anh
If aKL(1, j) = "VTU0190-11" Then
i = 1
End If
 
Lần chỉnh sửa cuối:
Upvote 0
quyenpv đã viết:
Dạ Code đúng rồi anh
Trường hợp khối lượng trạm đó =0 không cần tạo Sheet VTU riêng nhưng trong bảng tổng hợp PLHA_All vẫn để mã trạm đó và cột giá trị để =0 thì cần chỉnh đoạn này đúng không ạ
Sub Create_Res(aKL), chỉnh lệnh
If Tong > 0 Then
Thành
If k Then
Nhấp chuột vào đây để mở rộng...
Bỏ luôn lệnh if
 
Upvote 0
Dạ em cám ơn anh nhiều ạ
 
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

SA_DQ
  • Question Question
Bài tập VBA cho những người rỗi. . . đủ thứ! (3 người xem)
Trả lời
1
Đọc
67
HieuCD
H
L
Nhờ anh chị giúp đỡ công thức hàm len (2 người xem)
Trả lời
20
Đọc
118
linh34haiduong
L
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (5 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
3 4 5
Trả lời
413
Đọc
50K
tuanktt3
T
N
  • Question Question
Cho em hỏi về mail merge bằng vba (2 người xem)
Trả lời
7
Đọc
207
Hoàng Tuấn 868
H
N
Chuyển dấu chấm thành dấu chấm phẩy trong dữ liệu
Trả lời
3
Đọc
46
ptm0412
ptm0412
T
Khóa cột cập nhật dữ liệu
Trả lời
1
Đọc
100
HUONGHCKT
H
H
  • Question Question
Xin giúp đỡ về tạo hàm excel với C# và excel-dna
Trả lời
4
Đọc
145
hdcv.excel
H
befaint
Chia sẻ tâm tư, xả nỗi lòng (2 người xem)
    • Thích
6 7 8
Trả lời
761
Đọc
63K
befaint
befaint
B
Bỏ lọc và sort trong VBA
Trả lời
1
Đọc
65
Bảo_Anh_
B
K
Điền giá trị ô thay vì địa chỉ ô
Trả lời
5
Đọc
214
DeTong
D
T
Xin hỏi về bảng lương
Trả lời
1
Đọc
133
SA_DQ
SA_DQ
T
Nhờ anh chị xem giúp file bị lỗi gì mà chạy rất chậm/lag - File tính tiền nhà trọ
Trả lời
3
Đọc
119
Thaik05
T
J
chiết khấu ở hóa đơn bán lẻ, lưu vào sheet tổng hợp
Trả lời
2
Đọc
87
le_vis
L
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
8
Đọc
727
Hoàng Tuấn 868
H
B
Sau 1 tháng Mã Lại reset về 1 trở lên
    • Chấp nhận
Trả lời
23
Đọc
387
SA_DQ
SA_DQ
H
Đánh số thứ thự phiếu thu chi
Trả lời
16
Đọc
338
HangktGTN
H
4
HỌC ĐẠI LÝ THUẾ
Trả lời
1
Đọc
68
Hoàng Tuấn 868
H
B
Chuyển số tiền thành chữ (1 người xem)
Trả lời
3
Đọc
100
bongngongo
B
S
Tạo sheet mới từ dữ liệu 2 sheet khác ĐVT
Trả lời
1
Đọc
119
Hoàng Tuấn 868
H
H
Tìm kiếm thông tin chi tiết trên sheet tổng hợp
Trả lời
1
Đọc
115
LOGANWover
L
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