Giúp đỡ_Chỉnh Code lấy dữ liệu từ Sheet Khối lượng

Liên hệ QC
quyenpv

quyenpv

Thu nhặt kiến thức
Tham gia
5/1/13
Bài viết
719
Được thích
97
Giới tính
Nam
Nghề nghiệp
Decode cuộc đời!
Kính gửi các anh chị!
Lần mò mãi mà không sửa được code theo ý muốn nên mạo muội nhờ anh chị sửa giúp đoạn Code lấy dữ liệu từ Sheet Khối lượng sang Sheet Phụ lục. Phiền anh chị giúp đỡ em với ạ
1640688580408.png

Code em sửa chạy ra thế này ạ
1640688610759.png

Mong muốn của em cho đẹp khi in và không phải chỉnh tay nhiều Sheet (Code em viết lấy dữ liệu cho từng Sheet giống như file ạ)

1640688627539.png

Mã: 
Sub Run_PLBBNT_HT()

    'De xuat tao ma se lay cot T giao nhiem vu trien khai thi cong
'    On Error Resume Next
    Dim aTB_A(), aTB_B(), aKL_AB(), Res_A(), Res_B(), Res_KL()
    Dim sRow_A&, sRow_B&, sRow_KL&, I&, K_A&, j&, KL&, ktt&, K_B&, t&, tdR&, tdB As Boolean
    Dim LR_A, LR_B, LR_CV
    
    'Code trich loc hang muc cong viec
    With Sheets("KhoiLuong")
        aKL_AB = .Range("B9:S" & .Range("E" & .Rows.Count).End(xlUp).Row - 1).Value   'Lay dong cuoi cung cua ten CT
    End With
    sRow_KL = UBound(aKL_AB)
    ReDim Res_KL(1 To sRow_KL, 1 To 8)    'Chinh so cot
    KL = 0
    For j = 1 To sRow_KL
        If aKL_AB(j, 4) > 0 Then
            KL = KL + 1
            ktt = ktt + 1
            If aKL_AB(j, 1) = "HM" Then
                Res_KL(KL, 1) = aKL_AB(j, 1)
                ktt = 0
            Else
                Res_KL(KL, 1) = ktt                          'STT
            End If
            Res_KL(KL, 2) = aKL_AB(j, 4)                     'Ten VTTB
            Res_KL(KL, 3) = aKL_AB(j, 6)                     'Don vi tinh
            Res_KL(KL, 4) = aKL_AB(j, 7)                     'Kh.Luong giao khoan
            Res_KL(KL, 5) = aKL_AB(j, 17)                     'Kh.Luong thi cong
            If aKL_AB(j, 7) > aKL_AB(j, 17) Then
                Res_KL(KL, 6) = aKL_AB(j, 7) - aKL_AB(j, 17)
            Else
                Res_KL(KL, 6) = 0
            End If
            If aKL_AB(j, 7) < aKL_AB(j, 17) Then
                Res_KL(KL, 7) = aKL_AB(j, 17) - aKL_AB(j, 7)
            Else
                Res_KL(KL, 7) = 0
            End If
        End If
    Next j
  
    
    Sheets("PL_NTHT").Select
    With Sheets("PL_NTHT")

        LastRow = .Cells(Rows.Count, "N").End(xlUp).Row
        If LastRow > 14 Then
            'Xoa toan bo bang du lieu hien huu dang co
            .Rows("14:" & LastRow - 1).Delete Shift:=xlShiftUp
        Else
            .Range("C14:J" & LastRow + 1).ClearContents
        End If
        .Range("A14:A" & 14 + KL).EntireRow.Insert
        If KL Then
            .Range("C14").Resize(KL, 8).Value = Res_KL
            .Range("D14:E" & 14 + KL).WrapText = 1
            .Range("D14:D" & 14 + KL).HorizontalAlignment = xlJustify
            .Range("E14:F" & 14 + KL).VerticalAlignment = xlCenter
            .Range("C14:I" & 14 + KL).Font.Bold = False
            .Range("C14").Resize(KL, 8).Borders.LineStyle = 1
            .Rows("14:" & LastRow & "").EntireRow.AutoFit
        End If

    End With


End Sub
 

File đính kèm

  • Help_NT.xlsm
    44.4 KB · Đọc: 10
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Các con số sheet PLxxx lấy đâu ra thế
 
Upvote 0
quyenpv đã viết:
Dạ nó ở cột H "KHỐI LƯỢNG HỢP ĐỒNG/ TK" đó anh
Nhấp chuột vào đây để mở rộng...
Mã: 
Sub ABC()
Dim sArr(), Res(), i&, sR&, K&, KK&
With Sheets("KhoiLuong")
    sArr = .Range("A9:L" & .Range("E" & Rows.Count).End(3).Row - 1).Value
End With
sR = UBound(sArr, 1)
ReDim Res(1 To UBound(sArr, 1), 1 To 8)
For i = 1 To sR
    If sArr(i, 5) <> Empty Then
        K = K + 1
        If sArr(i, 2) = "HM" Then
            KK = 0
            Res(K, 1) = sArr(i, 2)
        Else
            KK = KK + 1
            Res(K, 1) = KK
        End If
        Res(K, 2) = sArr(i, 5): Res(K, 3) = sArr(i, 7)
        Res(K, 4) = sArr(i, 8): Res(K, 5) = sArr(i, 11)
            If Res(K, 4) > Res(K, 5) Then
                Res(K, 6) = Val(Res(K, 4)) - Val(Res(K, 5))
                Res(K, 7) = 0
            Else
                Res(K, 6) = 0
                Res(K, 7) = Val(Res(K, 5)) - Val(Res(K, 4))
            End If
    End If
 
Next
Sheets("PL_NTHT").Range("C14").Resize(K, 8) = Res
End Sub
Phần còn lại bạn tự tùy biến lấy nhé
 
Upvote 0
quyenpv đã viết:
Dạ nó ở cột H "KHỐI LƯỢNG HỢP ĐỒNG/ TK" đó anh
Nhấp chuột vào đây để mở rộng...
Xin lỗi. Hình như mình đang hiểu lầm ý bạn thì phải
Sửa lại code cùi bắp này coi
Mã: 
Sub ABC()
Dim Ws As Worksheet, Ws1 As Worksheet
Dim iRow&, eRow&, BD&, K&, i&, KK&
Set Ws = Sheets("KhoiLuong")
Set Ws1 = Sheets("PL_NTHT")
iRow = Ws.Range("B" & Rows.Count).End(3).Row - 1
With Ws1
    eRow = .Range("C" & Rows.Count).End(3).Row - 12
    If eRow < iRow + 11 Then
        .Range("C14:J14").Resize(iRow - eRow + 11).Insert xlShiftDown
    End If
End With
K = 13
For i = 9 To iRow
If Ws.Cells(i, 5) <> Empty Then
    If Ws.Cells(i, 4) Like "HM*" Then
        K = K + 1
        Ws1.Cells(K, 3) = Ws.Cells(i, 2)
        Ws1.Cells(K, 4) = Ws.Cells(i, 5)
        Ws1.Cells(K, 3).Resize(, 8).Interior.Color = vbYellow
    Else
        K = K + 1
        If Ws.Cells(i, 4) Like "GD*" Then
            Ws1.Cells(K, 3) = "*"
            Ws1.Cells(K, 4) = Ws.Cells(i, 5)
            KK = 0
        Else
            KK = KK + 1
            Ws1.Cells(K, 3) = KK
            Ws1.Cells(K, 4) = Ws.Cells(i, 5)
            Ws1.Cells(K, 5) = Ws.Cells(i, 7)
            Ws1.Cells(K, 6) = Ws.Cells(i, 8)
            Ws1.Cells(K, 7) = Ws.Cells(i, 11)
            If Ws1.Cells(K, 6) > Ws1.Cells(K, 7) Then
                Ws1.Cells(K, 9) = 0
                Ws1.Cells(K, 8) = Val(Ws1.Cells(K, 6)) - Val(Ws1.Cells(K, 7))
            Else
                Ws1.Cells(K, 8) = 0
                Ws1.Cells(K, 9) = Val(Ws1.Cells(K, 7)) - Val(Ws1.Cells(K, 6))
            End If
        End If
       
    End If
End If
Next
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
BuiQuangThuan đã viết:
Xin lỗi. Hình như mình đang hiểu lầm ý bạn thì phải
Sửa lại code cùi bắp này coi
Mã: 
Sub ABC()
Dim Ws As Worksheet, Ws1 As Worksheet
Dim iRow&, eRow&, BD&, K&, i&, KK&
Set Ws = Sheets("KhoiLuong")
Set Ws1 = Sheets("PL_NTHT")
iRow = Ws.Range("B" & Rows.Count).End(3).Row - 1
With Ws1
    eRow = .Range("C" & Rows.Count).End(3).Row - 12
    If eRow < iRow + 11 Then
        .Range("C14:J14").Resize(iRow - eRow + 11).Insert xlShiftDown
    End If
End With
K = 13
For i = 9 To iRow
If Ws.Cells(i, 5) <> Empty Then
    If Ws.Cells(i, 4) Like "HM*" Then
        K = K + 1
        Ws1.Cells(K, 3) = Ws.Cells(i, 2)
        Ws1.Cells(K, 4) = Ws.Cells(i, 5)
        Ws1.Cells(K, 3).Resize(, 8).Interior.Color = vbYellow
    Else
        K = K + 1
        If Ws.Cells(i, 4) Like "GD*" Then
            Ws1.Cells(K, 3) = "*"
            Ws1.Cells(K, 4) = Ws.Cells(i, 5)
            KK = 0
        Else
            KK = KK + 1
            Ws1.Cells(K, 3) = KK
            Ws1.Cells(K, 4) = Ws.Cells(i, 5)
            Ws1.Cells(K, 5) = Ws.Cells(i, 7)
            Ws1.Cells(K, 6) = Ws.Cells(i, 8)
            Ws1.Cells(K, 7) = Ws.Cells(i, 11)
            If Ws1.Cells(K, 6) > Ws1.Cells(K, 7) Then
                Ws1.Cells(K, 9) = 0
                Ws1.Cells(K, 8) = Val(Ws1.Cells(K, 6)) - Val(Ws1.Cells(K, 7))
            Else
                Ws1.Cells(K, 8) = 0
                Ws1.Cells(K, 9) = Val(Ws1.Cells(K, 7)) - Val(Ws1.Cells(K, 6))
            End If
        End If
      
    End If
End If
Next
End Sub
Nhấp chuột vào đây để mở rộng...
Em cám ơn anh!
Dựa vào Code của anh và code của anh HieuCD đã giúp em trước đó. Em đã áp dụng theo đúng ý mình còn tối ưu hay sai hay chưa thì còn tinh chỉnh tiếp ạ
Cám ơn các anh!
Mã: 
Sub Run_PLBBNT_HT()

    'De xuat tao ma se lay cot T giao nhiem vu trien khai thi cong
    On Error Resume Next
    Dim aTB_A(), aTB_B(), aKL_AB(), Res_A(), Res_B(), Res_KL()
    Dim sRow_A&, sRow_B&, sRow_KL&, I&, K_A&, j&, KL&, ktt&, K_B&, t&, tdR&, tdB As Boolean
    Dim LR_A, LR_B, LR_CV
    
    'Code trich loc hang muc cong viec
    With Sheets("KhoiLuong")
        aKL_AB = .Range("B9:S" & .Range("E" & .Rows.Count).End(xlUp).Row - 1).Value   'Lay dong cuoi cung cua ten CT
    End With
    sRow_KL = UBound(aKL_AB)
    ReDim Res_KL(1 To sRow_KL, 1 To 8)    'Chinh so cot
    KL = 0
    For j = 1 To sRow_KL
        If aKL_AB(j, 4) > 0 Then
            KL = KL + 1
            ktt = ktt + 1
            If aKL_AB(j, 3) Like "HM*" Then
                Res_KL(KL, 1) = aKL_AB(j, 1)
                Res_KL(KL, 2) = aKL_AB(j, 2)                     'Ten VTTB
                Res_KL(KL, 1).Resize(, 8).Interior.Color = vbYellow
                ktt = 0
            ElseIf aKL_AB(j, 3) Like "GD*" Then
                Res_KL(KL, 1) = "*"
                Res_KL(KL, 2) = aKL_AB(j, 2)
                ktt = 0
            Else
                Res_KL(KL, 1) = ktt                          'STT
            End If
            Res_KL(KL, 2) = aKL_AB(j, 4)                     'Ten VTTB
            Res_KL(KL, 3) = aKL_AB(j, 6)                     'Don vi tinh
            Res_KL(KL, 4) = aKL_AB(j, 7)                     'Kh.Luong giao khoan
            Res_KL(KL, 5) = aKL_AB(j, 17)                     'Kh.Luong thi cong
            If aKL_AB(j, 7) > aKL_AB(j, 17) And aKL_AB(j, 1) <> "GD" And aKL_AB(j, 1) <> "HM" Then
                Res_KL(KL, 6) = aKL_AB(j, 7) - aKL_AB(j, 17)
            Else
                Res_KL(KL, 6) = ""
            End If
            If aKL_AB(j, 7) < aKL_AB(j, 17) And aKL_AB(j, 1) <> "GD" And aKL_AB(j, 1) <> "HM" Then
                Res_KL(KL, 7) = aKL_AB(j, 17) - aKL_AB(j, 7)
            Else
                Res_KL(KL, 7) = ""
            End If
        End If
    Next j
  
    
    Sheets("PL_NTHT").Select
    With Sheets("PL_NTHT")

        LastRow = .Cells(Rows.Count, "N").End(xlUp).Row
        If LastRow > 14 Then
            'Xoa toan bo bang du lieu hien huu dang co
            .Rows("14:" & LastRow - 1).Delete Shift:=xlShiftUp
        Else
            .Range("C14:J" & LastRow + 1).ClearContents
        End If
        .Range("A14:A" & 14 + KL).EntireRow.Insert
        If KL Then
            .Range("C14").Resize(KL, 8).Value = Res_KL
            .Range("D14:E" & 14 + KL).WrapText = 1
            .Range("D14:D" & 14 + KL).HorizontalAlignment = xlJustify
            .Range("E14:F" & 14 + KL).VerticalAlignment = xlCenter
            .Range("C14:I" & 14 + KL).Font.Bold = False
            .Range("C14").Resize(KL, 8).Borders.LineStyle = 1
            .Rows("14:" & LastRow & "").EntireRow.AutoFit
            Call FormatTieude1(.Range("C14").Resize(KL, 2))
        End If

    End With


End Sub
Private Sub FormatTieude1(ByVal rng As Range)
    Dim sRow&, I&
    sRow = rng.Rows.Count
    For I = 1 To sRow
        If IsNumeric(rng(I, 1)) = False Then
            rng(I, 1).Resize(, 2).Font.Bold = True
            rng(I, 1).Resize(, 2).WrapText = False
            rng(I, 1).Resize(, 8).Interior.Color = RGB(214, 220, 228)
        End If
    Next I
End Sub
 
Upvote 0
quyenpv đã viết:
Dựa vào Code code của anh HieuCD đã giúp em trước đó. Em đã áp dụng theo đúng ý mình còn tối ưu hay sai hay chưa thì còn tinh chỉnh tiếp ạ
Nhấp chuột vào đây để mở rộng...
Là người này giúp code cho bạn rồi thì mình không có gì để thêm thắt nữa. Vì chắc chắn code của thầy ấy hiệu quả hơn của mình.Hihi.
 
Upvote 0
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

L
Nhờ giúp công thức nhiều điều kiện ngày không liên tục
Trả lời
0
Đọc
24
le_vis
L
N
Tính tổng giá trị hàng hóa của nhiều mặt hàng ( mỗi mặt hàng có 2 đến 3 giá )
2
Trả lời
34
Đọc
333
tranhungdao12a3
T
Hai Lúa Miền Tây
Nhập liệu, truy vấn dữ liệu qua Internet = VB.Net
    • Thích
2
Trả lời
32
Đọc
10K
nguyendang95
N
ongke0711
  • Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
9 10 11
Trả lời
211
Đọc
11K
dinhduy
D
dunghtgiga
Tính bốn tuần cho một tháng
Trả lời
2
Đọc
62
cantl
C
tamvie
Hướng dẫn dùng công cụ Goal Seek kết hợp với Macro để tính ra mức lương Gross
    • Thích
Trả lời
4
Đọc
2K
Hoàng Tuấn 868
H
keandanh141
Hướng dẫn hàm số tạo số ngẫu nhiên sao cho tổng bằng đúng 1 số
Trả lời
3
Đọc
66
SA_DQ
SA_DQ
T
File Excel bị đơ khi sửa số liệu
Trả lời
15
Đọc
130
Tìnhh Ry
T
dllt2805
MẪU QUẢN LÝ CÔNG VIỆC ĐỘI NHÓM BẰNG EXCEL
Trả lời
10
Đọc
995
dungluyen2119
dungluyen2119
B
Suy nghĩ của tui
    • Thích
2 3
Trả lời
58
Đọc
6K
SA_DQ
SA_DQ
thuyyeu99
  • Question
Kiểm tra file có tồn tại không
2
Trả lời
22
Đọc
13K
khonggianviet
K
Vũ trần bảo ngọc
Lỗi kết hợp hàm if và left
Trả lời
19
Đọc
257
HieuCD
H
T
Lỗi import dữ liệu
Trả lời
2
Đọc
155
hvnhpro
H
Quyen182
  • Question
Xin giúp code VBA để chèn ảnh có sẵn trong Excel vào phần comment
Trả lời
4
Đọc
260
Hoàng Tuấn 868
H
B
  • Question
Xin hướng dẫn tách 1 vùng dữ liệu sang thành nhiều sheet
Trả lời
4
Đọc
226
Bony_handsome
B
OverAC
Gặp gỡ giao lưu tại Hà Nội, chiều ngày 10/11/2024. cùng Ptm0412, OverAC và các anh chị thân thiết.
    • Thích
    • Yêu thích
Trả lời
9
Đọc
389
PhanTuHuong
PhanTuHuong
GPE-Trợ Lý
Đăng ký tham dự hội thảo tại Hà Nội: Power Query - Công cụ quản lý dữ liệu
    • Thích
    • Cảm ơn
    • Yêu thích
Trả lời
9
Đọc
840
ptm0412
ptm0412
Tuấn Bụng Bự
DataBase (CSDL) nào cho lập trình VBA trong Excel ?
Trả lời
18
Đọc
499
A HOANG 620
A
phuongnam366377
Excel RTD Add-In - Truy xuất dữ liệu File Excel, Access và SQLite
    • Thích
Trả lời
1
Đọc
324
phuongnam366377
phuongnam366377
T
Lấy dữ liệu từ sheet khác kèm điều kiện
Trả lời
3
Đọc
170
thuong-minh
T
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