Giúp đỡ_Chỉnh Code lấy dữ liệu từ Sheet Khối lượng (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)
quyenpv

quyenpv

Thu nhặt kiến thức
Tham gia
5/1/13
Bài viết
725
Đượ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

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

S
Hỏi về công thức tính tiền công theo Kg, có điều kiện. (1 người xem)
    • Cười
Trả lời
1
Đọc
19
SA_DQ
SA_DQ
Quang Ròm
  • Question Question
VBA nhảy qua lại 2 cột A B (1 người xem)
    • Cười
Trả lời
5
Đọc
58
Quang Ròm
Quang Ròm
N
Cho em xin hỏi về hàm Workday về ngày làm bù ạ
Trả lời
1
Đọc
26
hoangtuaotrang_hp_vn
H
K
dùng hàm sumproduct kết hợp nhiều điều kiện như thế nào?
Trả lời
2
Đọc
38
khanhnth02
K
tranaidh
Giúp sắp xếp phòng thi tốt nghiệp năm 2025
Trả lời
4
Đọc
246
BuiQuangThuan
B
V
Cập nhật DataValidation 2 chiều giữa 2 sheet
Trả lời
4
Đọc
167
hoangtuaotrang_hp_vn
H
nghiahandsome1995
  • Question Question
in đậm chuỗi văn bản bằng excel
Trả lời
11
Đọc
297
HUONGHCKT
H
nghiahandsome1995
Xin mã code autofit
Trả lời
0
Đọc
30
nghiahandsome1995
nghiahandsome1995
D
tạo pivot table theo nhiều trường dữ liệu phân loại
Trả lời
4
Đọc
93
duymax1234567
D
H
Cách nào có thể gộp dữ liệu không dùng VBA (1 người xem)
Trả lời
9
Đọc
116
Hoang NS
H
B
Xin tư vấn excel tính giá trị cho nhiều trường hợp (1 người xem)
    • Ngạc nhiên
    • Phẫn nộ
Trả lời
5
Đọc
280
hangnguyenkt
H
A
Giúp đỡ tính tổng ô hàng ngang bất kỳ !
Trả lời
8
Đọc
193
anhdung411
A
T
  • Question Question
Ẩn hiện các sheet khi click vào HyperLink
Trả lời
5
Đọc
166
DeTong
D
PhanTuHuong
Hà Nội hẹn hò gặp gỡ đầu năm 2025 thôi :)
    • Thích
    • Yêu thích
Trả lời
5
Đọc
246
PhanTuHuong
PhanTuHuong
DinhManh1307
Cách thống kê công việc sản xuất từng người để tính lương sản phẩm
Trả lời
6
Đọc
80
DeTong
D
T
Bảng tính trợ cấp theo Nghị định 178 và tính lương hưu
    • Thích
Trả lời
8
Đọc
785
thanhkhoavp
T
sangvanng92
  • Question Question
Cách chạy file excel chứa code vba trên sharepoint
Trả lời
2
Đọc
141
Nguyễn Duy Tuân
Nguyễn Duy Tuân
ankhanh2k2
sắp xếp dữ liệu chấm công
    • Buồn
Trả lời
8
Đọc
247
pycckuu410
P
PhanTuHuong
CHỌN VÀ SỬ DỤNG MÁY LỌC KHÔNG KHÍ
    • Thích
    • Cảm ơn
Trả lời
6
Đọc
868
PhanTuHuong
PhanTuHuong
Tuấn Bụng Bự
tạo QRcode chuyển khoản ngân hàng
Trả lời
4
Đọc
121
HeSanbi
HeSanbi
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

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
TALK SHOW EXCEL TRONG SẢN XUẤT
Back
Top Bottom