Liệt kê Vật tư chưa thu hồi sử dụng Dictionary bị lỗi

Liên hệ QC
quyenpv

quyenpv

Thu nhặt kiến thức
Tham gia
5/1/13
Bài viết
709
Được thích
90
Giới tính
Nam
Nghề nghiệp
Decode cuộc đời!
Hiện nay khâu đối soát vật tư giao nhà thầu thi công rất nhức đầu và thường xuyên phải chốt biên bản mất mát và yêu cầu đền vật tư với các đơn vị
Em có bảng đối sót vật tư trong đó có S.Luong Xuất kho - S.Luong thực tế - S.Luong đã Nhập kho = Số lượng đền bù mất mát
Em đang tập tành sử dụng Dictionary để liệt kê mã vật tư và lấy giá trị mong muốn. Gặt lỗi cùng 1 mã vật tư nhưng đơn giá vật tư lại khác nhau
Nếu cùng mã, cùng đơn giá thì cộng các giá trị lại và liệt kê vào bảng, Ngược lại cùng mã vật tư nhưng khác đơn giá thi không cộng và liệt kê vào bảng
Mong anh chị sửa giúp em với ạ
Mã: 
Sub BBLV_MatVTu()
    Dim Dic1 As Object, iRow As Long, i As Long
    Dim Arr() As Variant, TmpArr As Variant
    With Sheet1
    .Range("A5:K100").ClearContents
      Set Dic1 = CreateObject("Scripting.Dictionary")                                   'Tao Dic
        EndR = Sheet37.[F65000].End(xlUp).Row
        TmpArr = Sheet37.Range("B11:G" & EndR).Value
      
        ReDim Arr(1 To UBound(TmpArr, 1), 1 To 10)                                       'Xac dinh Kich thuoc mang Arr dua tren mang TmpArr
        For iRow = 1 To UBound(TmpArr, 1)                                               'Dung vong lap duyet qua chieu doc cua mang tu B2 den G21
            If Not IsEmpty(TmpArr(iRow, 4)) And Not Dic1.Exists(TmpArr(iRow, 4)) Then   'Bat dau iRow = 1, neu B12 khong rong và ko ton tai
                i = i + 1
                 Dic1.Add TmpArr(iRow, 4), i
                 Arr(i, 1) = TmpArr(iRow, 4)                            'Ma VT
                 Arr(i, 2) = TmpArr(iRow, 3)                            'Ten Vat
                 Arr(i, 3) = "dvt"                                      'DVT
'                 Arr(i, 9) = TmpArr(iRow, 6)
                If TmpArr(iRow, 5) <> 0 Then                            'Ktra so luong xuat <>0
                   Arr(i, 4) = TmpArr(iRow, 5)                          'So luong
                End If
            Else
                If TmpArr(iRow, 5) <> 0 Then                            'Ktra MVT neu trung ma thi + them Sluong xuat kho
                    Arr(Dic1.Item(TmpArr(iRow, 4)), 4) = Arr(Dic1.Item(TmpArr(iRow, 4)), 4) + TmpArr(iRow, 5)
                    Arr(i, 9) = TmpArr(iRow, 6)
                Else
                    Arr(Dic1.Item(TmpArr(iRow, 4)), 4) = Arr(Dic1.Item(TmpArr(iRow, 4)), 4) ' + TmpArr(iRow, 5)
                    Arr(i, 9) = TmpArr(iRow, 6)
                End If
            End If
        Next iRow
    .Range("B5").Resize(i, 10).Value = Arr
  
    End With
End Sub
 

File đính kèm

  • Help_BBLV_Dictionary.xlsm
    234.1 KB · Đọc: 16
  • 1.PNG
    1.PNG
    31.9 KB · Đọc: 6
  • 2.PNG
    2.PNG
    35 KB · Đọc: 7
Sắp xếp theo thời gian sắp xếp theo bầu chọn
quyenpv đã viết:
Hiện nay khâu đối soát vật tư giao nhà thầu thi công rất nhức đầu và thường xuyên phải chốt biên bản mất mát và yêu cầu đền vật tư với các đơn vị
Em có bảng đối sót vật tư trong đó có S.Luong Xuất kho - S.Luong thực tế - S.Luong đã Nhập kho = Số lượng đền bù mất mát
Em đang tập tành sử dụng Dictionary để liệt kê mã vật tư và lấy giá trị mong muốn. Gặt lỗi cùng 1 mã vật tư nhưng đơn giá vật tư lại khác nhau
Nếu cùng mã, cùng đơn giá thì cộng các giá trị lại và liệt kê vào bảng, Ngược lại cùng mã vật tư nhưng khác đơn giá thi không cộng và liệt kê vào bảng
Mong anh chị sửa giúp em với ạ
Mã: 
Sub BBLV_MatVTu()
    Dim Dic1 As Object, iRow As Long, i As Long
    Dim Arr() As Variant, TmpArr As Variant
    With Sheet1
    .Range("A5:K100").ClearContents
      Set Dic1 = CreateObject("Scripting.Dictionary")                                   'Tao Dic
        EndR = Sheet37.[F65000].End(xlUp).Row
        TmpArr = Sheet37.Range("B11:G" & EndR).Value
     
        ReDim Arr(1 To UBound(TmpArr, 1), 1 To 10)                                       'Xac dinh Kich thuoc mang Arr dua tren mang TmpArr
        For iRow = 1 To UBound(TmpArr, 1)                                               'Dung vong lap duyet qua chieu doc cua mang tu B2 den G21
            If Not IsEmpty(TmpArr(iRow, 4)) And Not Dic1.Exists(TmpArr(iRow, 4)) Then   'Bat dau iRow = 1, neu B12 khong rong và ko ton tai
                i = i + 1
                 Dic1.Add TmpArr(iRow, 4), i
                 Arr(i, 1) = TmpArr(iRow, 4)                            'Ma VT
                 Arr(i, 2) = TmpArr(iRow, 3)                            'Ten Vat
                 Arr(i, 3) = "dvt"                                      'DVT
'                 Arr(i, 9) = TmpArr(iRow, 6)
                If TmpArr(iRow, 5) <> 0 Then                            'Ktra so luong xuat <>0
                   Arr(i, 4) = TmpArr(iRow, 5)                          'So luong
                End If
            Else
                If TmpArr(iRow, 5) <> 0 Then                            'Ktra MVT neu trung ma thi + them Sluong xuat kho
                    Arr(Dic1.Item(TmpArr(iRow, 4)), 4) = Arr(Dic1.Item(TmpArr(iRow, 4)), 4) + TmpArr(iRow, 5)
                    Arr(i, 9) = TmpArr(iRow, 6)
                Else
                    Arr(Dic1.Item(TmpArr(iRow, 4)), 4) = Arr(Dic1.Item(TmpArr(iRow, 4)), 4) ' + TmpArr(iRow, 5)
                    Arr(i, 9) = TmpArr(iRow, 6)
                End If
            End If
        Next iRow
    .Range("B5").Resize(i, 10).Value = Arr
 
    End With
End Sub
Nhấp chuột vào đây để mở rộng...
Trong sheet BQT-VTU thấy có mấy cột đơn giá, không biết lấy cột đơn giá nào luôn, hay là các cột đó cùng 1 đơn giá cho từng dòng?
Bạn có thể gộp Mã vật tư và đơn giá làm 1 Key cho dictionary, lúc đó thì có thể lấy danh sách trùng mã vật tư nhưng khác đơn giá
 
Upvote 0
Mã: 
Option Explicit

Sub BBLV_AT()
    Dim Dic1 As Object, iRow As Long, i As Long, k, dK, a, EndR
    Dim Arr() As Variant, TmpArr As Variant
    With Sheet1
        .Range("n5:x100").ClearContents
        Set Dic1 = CreateObject("Scripting.Dictionary")                                   'Tao Dic
        EndR = Sheet1.[B65000].End(xlUp).Row
        TmpArr = Sheet1.Range("B5:K" & EndR).Value

        ReDim Arr(1 To UBound(TmpArr, 1), 1 To 10)                                       'Xac dinh Kich thuoc mang Arr dua tren mang TmpArr
        For iRow = 1 To UBound(TmpArr, 1)
            dK = TmpArr(iRow, 1) & "#" & TmpArr(iRow, 9)
            If Not IsEmpty(dK) And Not Dic1.Exists(dK) Then
                i = i + 1
                Dic1.Add dK, i
                Arr(i, 1) = TmpArr(iRow, 1)                            'Ma VT
                Arr(i, 2) = TmpArr(iRow, 2)                            'Ten Vat
                Arr(i, 3) = TmpArr(iRow, 3)                                       'DVT
                Arr(i, 4) = TmpArr(iRow, 4)
                Arr(i, 5) = TmpArr(iRow, 5)
                Arr(i, 6) = TmpArr(iRow, 6)
                Arr(i, 7) = TmpArr(iRow, 7)
                Arr(i, 8) = TmpArr(iRow, 8)
                Arr(i, 9) = TmpArr(iRow, 9)
                Arr(i, 10) = TmpArr(iRow, 10)

                a = Dic1.Item(dK)

            Else
                    
                Arr(a, 4) = Arr(a, 4) + TmpArr(iRow, 4)
                Arr(a, 5) = Arr(a, 5) + TmpArr(iRow, 5)
                Arr(a, 6) = Arr(a, 6) + TmpArr(iRow, 6)
                Arr(a, 7) = Arr(a, 7) + TmpArr(iRow, 7)
                Arr(a, 8) = Arr(a, 8) + TmpArr(iRow, 8)
                Arr(a, 10) = Arr(a, 10) + TmpArr(iRow, 10)
                End If
                   Next iRow
        .Range("n5").Resize(i, 10).Value = Arr

    End With
End Sub
bạn thử kiểm tra lại kết quả
Nếu muốn học Dic, bạn có thể kiếm những chủ đề của tui
 
Upvote 0
Lê Hồng Minh83 đã viết:
Trong sheet BQT-VTU thấy có mấy cột đơn giá, không biết lấy cột đơn giá nào luôn, hay là các cột đó cùng 1 đơn giá cho từng dòng?
Bạn có thể gộp Mã vật tư và đơn giá làm 1 Key cho dictionary, lúc đó thì có thể lấy danh sách trùng mã vật tư nhưng khác đơn giá
Nhấp chuột vào đây để mở rộng...
Vâng anh, em lấy theo mã vật tư từ Sheet BQT_VTU đưa sang bảng tại Sheet1. Nếu đơn giá (cột G tại Sheet BQT_VTU) khác nhau thì liệt kê riêng theo giá, trùng đơn giá thì tính tổng anh
CHỈ LẤY NHỮNG VẬT TƯ TẠI CỘT O của Sheet BQT_VTU CÓ SỐ LƯỢNG >0 anh ạ
 
Lần chỉnh sửa cuối:
Upvote 0
AnhThu-1976 đã viết:
Mã: 
Option Explicit

Sub BBLV_AT()
    Dim Dic1 As Object, iRow As Long, i As Long, k, dK, a, EndR
    Dim Arr() As Variant, TmpArr As Variant
    With Sheet1
        .Range("n5:x100").ClearContents
        Set Dic1 = CreateObject("Scripting.Dictionary")                                   'Tao Dic
        EndR = Sheet1.[B65000].End(xlUp).Row
        TmpArr = Sheet1.Range("B5:K" & EndR).Value

        ReDim Arr(1 To UBound(TmpArr, 1), 1 To 10)                                       'Xac dinh Kich thuoc mang Arr dua tren mang TmpArr
        For iRow = 1 To UBound(TmpArr, 1)
            dK = TmpArr(iRow, 1) & "#" & TmpArr(iRow, 9)
            If Not IsEmpty(dK) And Not Dic1.Exists(dK) Then
                i = i + 1
                Dic1.Add dK, i
                Arr(i, 1) = TmpArr(iRow, 1)                            'Ma VT
                Arr(i, 2) = TmpArr(iRow, 2)                            'Ten Vat
                Arr(i, 3) = TmpArr(iRow, 3)                                       'DVT
                Arr(i, 4) = TmpArr(iRow, 4)
                Arr(i, 5) = TmpArr(iRow, 5)
                Arr(i, 6) = TmpArr(iRow, 6)
                Arr(i, 7) = TmpArr(iRow, 7)
                Arr(i, 8) = TmpArr(iRow, 8)
                Arr(i, 9) = TmpArr(iRow, 9)
                Arr(i, 10) = TmpArr(iRow, 10)

                a = Dic1.Item(dK)

            Else
                  
                Arr(a, 4) = Arr(a, 4) + TmpArr(iRow, 4)
                Arr(a, 5) = Arr(a, 5) + TmpArr(iRow, 5)
                Arr(a, 6) = Arr(a, 6) + TmpArr(iRow, 6)
                Arr(a, 7) = Arr(a, 7) + TmpArr(iRow, 7)
                Arr(a, 8) = Arr(a, 8) + TmpArr(iRow, 8)
                Arr(a, 10) = Arr(a, 10) + TmpArr(iRow, 10)
                End If
                   Next iRow
        .Range("n5").Resize(i, 10).Value = Arr

    End With
End Sub
Nhấp chuột vào đây để mở rộng...
Các anh chị cho em hỏi
Code trên của em khi gán xuống sheet ở cột N thì những mã có số 0 ở đầu
Ví dụ: 0123 thì gán xuống sheet thành 123
Bây giờ code thêm chổ nào để 0123 gán xuống sheet vẫn là 0123
P/s: Ngoài trừ cách định dạng cột N là Text trước khi gán xuống (nghĩa là định dạng Text trước khi chạy code)
Em cảm ơn!
 
Upvote 0
.Range("n5").Resize(i).Numberformat=”@”
BẠn thêm câu lệnh trước bước gán mảng kết quả xuống sheet.
 
Upvote 0
Range("N5:N" & UBound(TmpArr)).NumberFormat = "@"
Thêm dòng trên trước câu lệnh
.Range("n5").Resize(i, 10).Value = Arr
 
Upvote 0
Giúp em vấn đề trên với anh chị
 
Upvote 0
quyenpv đã viết:
Hiện nay khâu đối soát vật tư giao nhà thầu thi công rất nhức đầu và thường xuyên phải chốt biên bản mất mát và yêu cầu đền vật tư với các đơn vị
Em có bảng đối sót vật tư trong đó có S.Luong Xuất kho - S.Luong thực tế - S.Luong đã Nhập kho = Số lượng đền bù mất mát
Em đang tập tành sử dụng Dictionary để liệt kê mã vật tư và lấy giá trị mong muốn. Gặt lỗi cùng 1 mã vật tư nhưng đơn giá vật tư lại khác nhau
Nếu cùng mã, cùng đơn giá thì cộng các giá trị lại và liệt kê vào bảng, Ngược lại cùng mã vật tư nhưng khác đơn giá thi không cộng và liệt kê vào bảng
Mong anh chị sửa giúp em với ạ
Mã: 
Sub BBLV_MatVTu()
    Dim Dic1 As Object, iRow As Long, i As Long
    Dim Arr() As Variant, TmpArr As Variant
    With Sheet1
    .Range("A5:K100").ClearContents
      Set Dic1 = CreateObject("Scripting.Dictionary")                                   'Tao Dic
        EndR = Sheet37.[F65000].End(xlUp).Row
        TmpArr = Sheet37.Range("B11:G" & EndR).Value
     
        ReDim Arr(1 To UBound(TmpArr, 1), 1 To 10)                                       'Xac dinh Kich thuoc mang Arr dua tren mang TmpArr
        For iRow = 1 To UBound(TmpArr, 1)                                               'Dung vong lap duyet qua chieu doc cua mang tu B2 den G21
            If Not IsEmpty(TmpArr(iRow, 4)) And Not Dic1.Exists(TmpArr(iRow, 4)) Then   'Bat dau iRow = 1, neu B12 khong rong và ko ton tai
                i = i + 1
                 Dic1.Add TmpArr(iRow, 4), i
                 Arr(i, 1) = TmpArr(iRow, 4)                            'Ma VT
                 Arr(i, 2) = TmpArr(iRow, 3)                            'Ten Vat
                 Arr(i, 3) = "dvt"                                      'DVT
'                 Arr(i, 9) = TmpArr(iRow, 6)
                If TmpArr(iRow, 5) <> 0 Then                            'Ktra so luong xuat <>0
                   Arr(i, 4) = TmpArr(iRow, 5)                          'So luong
                End If
            Else
                If TmpArr(iRow, 5) <> 0 Then                            'Ktra MVT neu trung ma thi + them Sluong xuat kho
                    Arr(Dic1.Item(TmpArr(iRow, 4)), 4) = Arr(Dic1.Item(TmpArr(iRow, 4)), 4) + TmpArr(iRow, 5)
                    Arr(i, 9) = TmpArr(iRow, 6)
                Else
                    Arr(Dic1.Item(TmpArr(iRow, 4)), 4) = Arr(Dic1.Item(TmpArr(iRow, 4)), 4) ' + TmpArr(iRow, 5)
                    Arr(i, 9) = TmpArr(iRow, 6)
                End If
            End If
        Next iRow
    .Range("B5").Resize(i, 10).Value = Arr
 
    End With
End Sub
Nhấp chuột vào đây để mở rộng...
Trong code chỉ tính số lượng tàm tạm
Mã: 
Sub BB_MatVTu()
  Dim Dic As Object, iKey$
  Dim sArr(), Res() As String, Res2()
  Dim eRow&, sRow&, i&, ik&
 
  Set Dic = CreateObject("Scripting.Dictionary")
  With Sheet37
    eRow = .[E1000000].End(xlUp).Row 'dong cuoi
    sArr = .Range("D11:R" & eRow).Value 'du lieu nguon
  End With
  sRow = UBound(sArr)
  ReDim Res(1 To sRow, 1 To 3)
  ReDim Res2(1 To sRow, 1 To 7)
  For i = 1 To sRow
    If Len(sArr(i, 2)) Then ' neu co ma vat tu
      iKey = sArr(i, 2) & "#" & sArr(i, 4)
      If Not Dic.exists(iKey) Then
        k = k + 1
        Dic.Add iKey, k
        Res(k, 1) = sArr(i, 2)
        Res(k, 2) = sArr(i, 1)
        Res(k, 3) = "Dvt"
        Res2(k, 6) = sArr(i, 4)
      End If
      ik = Dic.Item(iKey)
      Res2(ik, 1) = Res2(ik, 1) + sArr(i, 3)
      Res2(ik, 2) = Res2(ik, 2) + sArr(i, 6)
      Res2(ik, 3) = Res2(ik, 1) - Res2(ik, 2)
      Res2(ik, 4) = Res2(ik, 4) + sArr(i, 9)
      Res2(ik, 5) = Res2(ik, 3) - Res2(ik, 4)
      Res2(ik, 7) = Res2(ik, 5) * Res2(ik, 6)
    End If
  Next i
  For i = 1 To k
    For j = 1 To 7
      If Res2(i, j) = 0 Then Res2(i, j) = Empty
    Next j
  Next i
  With Sheet1
    .Range("A5:K100").ClearContents
    .Range("B5").Resize(k, 3).Value = Res
    .Range("E5").Resize(k, 7).Value = Res2
  End With
End Sub
 
Upvote 0
Cám ơn anh HieuCD đã hỗ trợ, em lấy theo mã vật tư từ Sheet BQT_VTU đưa sang bảng tại Sheet1. Nếu đơn giá (cột G tại Sheet BQT_VTU) khác nhau thì liệt kê riêng theo giá, trùng đơn giá thì tính tổng anh
CHỈ LẤY NHỮNG VẬT TƯ TẠI CỘT O của Sheet BQT_VTU CÓ SỐ LƯỢNG >0 anh ạ
 
Upvote 0
quyenpv đã viết:
Cám ơn anh HieuCD đã hỗ trợ, em lấy theo mã vật tư từ Sheet BQT_VTU đưa sang bảng tại Sheet1. Nếu đơn giá (cột G tại Sheet BQT_VTU) khác nhau thì liệt kê riêng theo giá, trùng đơn giá thì tính tổng anh
CHỈ LẤY NHỮNG VẬT TƯ TẠI CỘT O của Sheet BQT_VTU CÓ SỐ LƯỢNG >0 anh ạ
Nhấp chuột vào đây để mở rộng...
Chỉnh sửa code trên chút xíu, bạn kiểm tra lại xem ok chưa nhé
 

File đính kèm

  • Help_BBLV_Dictionary.xlsm
    183 KB · Đọc: 7
Upvote 0
Thanks anh, để em test kiểm tra ạ. Tối qua em có thử nhưng toàn thông báo lỗi hóa ra đặt sai dòng End If1569547325279.png
 
Upvote 0
quyenpv đã viết:
Cám ơn anh HieuCD đã hỗ trợ, em lấy theo mã vật tư từ Sheet BQT_VTU đưa sang bảng tại Sheet1. Nếu đơn giá (cột G tại Sheet BQT_VTU) khác nhau thì liệt kê riêng theo giá, trùng đơn giá thì tính tổng anh
CHỈ LẤY NHỮNG VẬT TƯ TẠI CỘT O của Sheet BQT_VTU CÓ SỐ LƯỢNG >0 anh ạ
Nhấp chuột vào đây để mở rộng...
Chưa hiểu ý, cho ví vụ cụ thể vài trường hợp
Mã: 
Sub BB_MatVTu()
  Dim Dic As Object, iKey$
  Dim sArr(), Res() As String, Res2()
  Dim eRow&, sRow&, i&, ik&
 
  Set Dic = CreateObject("Scripting.Dictionary")
  With Sheet37
    eRow = .[E1000000].End(xlUp).Row 'dong cuoi
    sArr = .Range("D11:R" & eRow).Value 'du lieu nguon
  End With
  sRow = UBound(sArr)
  ReDim Res(1 To sRow, 1 To 3)
  ReDim Res2(1 To sRow, 1 To 7)
  For i = 1 To sRow
    If Len(sArr(i, 12)) Then ' neu co So luong chua thu hoi
      iKey = sArr(i, 2) & "#" & sArr(i, 4) 'Cung ma vat tu va cung don gia xuat kho (cot G)
      If Not Dic.exists(iKey) Then
        k = k + 1
        Dic.Add iKey, k
        Res(k, 1) = sArr(i, 2)
        Res(k, 2) = sArr(i, 1)
        Res(k, 3) = "Dvt"
        Res2(k, 6) = sArr(i, 4)
      End If
      ik = Dic.Item(iKey)
      Res2(ik, 1) = Res2(ik, 1) + sArr(i, 3)
      Res2(ik, 2) = Res2(ik, 2) + sArr(i, 6)
      Res2(ik, 3) = Res2(ik, 1) - Res2(ik, 2)
      Res2(ik, 4) = Res2(ik, 4) + sArr(i, 9)
      Res2(ik, 5) = Res2(ik, 3) - Res2(ik, 4)
      Res2(ik, 7) = Res2(ik, 5) * Res2(ik, 6)
    End If
  Next i
  For i = 1 To k
    For j = 1 To 7
      If Res2(i, j) = 0 Then Res2(i, j) = Empty
    Next j
  Next i
  With Sheet1
    .Range("A5:K100").ClearContents
    .Range("B5").Resize(k, 3).Value = Res
    .Range("E5").Resize(k, 7).Value = Res2
  End With
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.
Web KT

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

son0611excel
  • Question
VBA tra cứu hình theo điều kiện
Trả lời
11
Đọc
238
tle2003
T
Salem999999999
Lọc dữ liệu có điều kiện
2
Trả lời
25
Đọc
563
tle2003
T
vuongnlks
Lấy dữ liệu 1 cột cụ thể theo ngày từ nhiều file CSV ứng với mã tương ứng trong cột MA CO PHIEU
Trả lời
1
Đọc
87
BuiQuangThuan
B
V
Hỗ trợ hàm Sumproduct và Subtotal trong GG Sheets
Trả lời
3
Đọc
231
ngocphuongchip123
ngocphuongchip123
K
Tính tổng có điều kiện
Trả lời
4
Đọc
160
kimson_nb
K
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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