Nhờ trợ giúp code tham chiếu và điền giá trị không trùng theo điều kiện (1 người xem)

Binbo2020 · 10/10/17

Mình có một file cập nhật số liệu hàng ngày như sau:
1- (sheet!san_luong) cập nhật hàng ngày theo ngày, ca. Một số xe trong một ngày một ca một xe có thể chạy nhiều loại hàng khác nhau, số lượng và quãng đường khác nhau.
2- (sheet!dau) cũng được cập nhật tương tự nhưng mỗi ngày, ca, một số xe thì chỉ có một lái xe và một lượng dầu.
Mình muốn cập nhật lái xe, lượng dầu từ (sheet!dau) sang (sheet!san_luong) theo nguyên tắc một ngày một ca một số xe thì chỉ gán lái xe và dầu một lần duy nhất cho xe đó.
File kèm theo mình đang tạm lấy một ít dữ liệu và điền bằng tay vào. Nhờ mọi người trên GPE trợ giúp mình code với vì dữ liệu nhiều không nhặt bằng tay được.

anhtuanle123 · 12/10/17

nếu dữ liệu bạn tổ chức như này thì thông tin 5 cột (Ngay ,Thang ,Nam ,ca, Xe) sẽ là khóa chính !
nghĩa là 1 ca thì 1 xe chỉ được chở 1 loại hàng thôi ,
muốn chở loại hàng khác thì phải sang ca khác !
làm bài này bạn làm 1 cột phụ nối 5 cột lại rồi Vlook up là đc , chắc ko cần dùng macro đâu !
_______________
mò 1 hồi bằng công thức ko đc , vướng ở chỗ chọn khóa duy nhất !
làm bằng macro thử !^^

Binbo2020 · 12/10/17

anhtuanle123 đã viết:
nếu dữ liệu bạn tổ chức như này thì thông tin 5 cột (Ngay ,Thang ,Nam ,ca, Xe) sẽ là khóa chính !
nghĩa là 1 ca thì 1 xe chỉ được chở 1 loại hàng thôi ,
muốn chở loại hàng khác thì phải sang ca khác !
làm bài này bạn làm 1 cột phụ nối 5 cột lại rồi Vlook up là đc , chắc ko cần dùng macro đâu !
_______________
mò 1 hồi bằng công thức ko đc , vướng ở chỗ chọn khóa duy nhất !
làm bằng macro thử !^^

Dữ liệu của mình một ngày, ca có một lái xe, một xe.
Nhưng các chuyến chạy hàng trong ca rất nhiều loại hàng nên phần sản lượng mới phải phân ra như thế.
Còn dầu thì chạy hết ca mới chốt dầu tồn nên dầu lại chỉ xuất hiện một lần.
Cám ơn bạn rất nhiều, mình tắc ở vấn đề này nhiều ngày mà không làm được.
Công việc của mình còn mấy việc phải tách tương tự thế này
Bạn có thể giúp thêm mình giải thích các đoạn code được không.
Để mình có thể áp dụng vào các phần việc khác
Mình mới tiếp cận VBA nên nhìn hoa hết mắt.

anhtuanle123 · 12/10/17

bạn xem thử nha , nếu ko hỉu thì nhắn tin cho mình !

Binbo2020 · 13/10/17

anhtuanle123 đã viết:
bạn xem thử nha , nếu ko hỉu thì nhắn tin cho mình !

Cám ơn bạn rất nhiều mình áp dụng được vào việc tương tự rồi.
Cho mình hỏi thêm một bài ngược lại với bài này.
Vẫn là tìm kiếm nhiều điều kiện
nhưng là cứ điều kiện trùng thì ghi ra giá trị.
Hiện mình đang dùng công thức excel để tham chiếu ở cột K và L
nhưng khi dữ liệu lũy kế lên thì chạy hay đơ máy
Bạn xem giúp mình với.

Ba Tê · 14/10/17

hongtrang26 đã viết:
Cám ơn bạn rất nhiều mình áp dụng được vào việc tương tự rồi.
Cho mình hỏi thêm một bài ngược lại với bài này.
Vẫn là tìm kiếm nhiều điều kiện
nhưng là cứ điều kiện trùng thì ghi ra giá trị.
Hiện mình đang dùng công thức excel để tham chiếu ở cột K và L
nhưng khi dữ liệu lũy kế lên thì chạy hay đơ máy
Bạn xem giúp mình với.

Viết cho bạn 1 Sub, chạy để thay cho các công thức SUMIFS() trong cột K,L.

PHP:

Public Sub GPE()
Dim sArr(), dArr(), tArr(), I As Long, J As Long, R As Long, Tem As String, Rws As Long
With CreateObject("Scripting.Dictionary")
    With Sheets("quang_duong")
        tArr = .Range("A7", .Range("A7").End(xlDown)).Resize(, 9).Value
        R = UBound(tArr)
    End With
    For I = 1 To R
        Tem = Empty
        For J = 1 To 7
            Tem = Tem & "#" & tArr(I, J)
        Next J
        If Not .Exists(Tem) Then
            .Item(Tem) = I
        Else
            Rws = .Item(Tem)
            tArr(Rws, 8) = tArr(Rws, 8) + tArr(I, 8)
            tArr(Rws, 9) = tArr(Rws, 9) + tArr(I, 9)
        End If
    Next I
    With Sheets("san_luong")
        sArr = .Range("A7", .Range("A7").End(xlDown)).Resize(, 8).Value
        R = UBound(sArr): ReDim dArr(1 To R, 1 To 2)
    End With
    For I = 1 To R
        Tem = Empty
        For J = 1 To 8
            If J <> 5 Then Tem = Tem & "#" & sArr(I, J)
        Next J
                If .Exists(Tem) Then
                    Rws = .Item(Tem)
                    dArr(I, 1) = tArr(Rws, 8)
                    dArr(I, 2) = tArr(Rws, 9)
                End If
    Next I
End With
Sheets("san_luong").Range("K7:L7").Resize(R) = dArr
End Sub

Binbo2020 · 14/10/17

Ba Tê đã viết:

Viết cho bạn 1 Sub, chạy để thay cho các công thức SUMIFS() trong cột K,L.

PHP:

Public Sub GPE()
Dim sArr(), dArr(), tArr(), I As Long, J As Long, R As Long, Tem As String, Rws As Long
With CreateObject("Scripting.Dictionary")
    With Sheets("quang_duong")
        tArr = .Range("A7", .Range("A7").End(xlDown)).Resize(, 9).Value
        R = UBound(tArr)
    End With
    For I = 1 To R
        Tem = Empty
        For J = 1 To 7
            Tem = Tem & "#" & tArr(I, J)
        Next J
        If Not .Exists(Tem) Then
            .Item(Tem) = I
        Else
            Rws = .Item(Tem)
            tArr(Rws, 8) = tArr(Rws, 8) + tArr(I, 8)
            tArr(Rws, 9) = tArr(Rws, 9) + tArr(I, 9)
        End If
    Next I
    With Sheets("san_luong")
        sArr = .Range("A7", .Range("A7").End(xlDown)).Resize(, 8).Value
        R = UBound(sArr): ReDim dArr(1 To R, 1 To 2)
    End With
    For I = 1 To R
        Tem = Empty
        For J = 1 To 8
            If J <> 5 Then Tem = Tem & "#" & sArr(I, J)
        Next J
                If .Exists(Tem) Then
                    Rws = .Item(Tem)
                    dArr(I, 1) = tArr(Rws, 8)
                    dArr(I, 2) = tArr(Rws, 9)
                End If
    Next I
End With
Sheets("san_luong").Range("K7:L7").Resize(R) = dArr
End Sub

Cám ơn bạn rất nhiều. Bạn có thể ghi chú từng đoạn code giúp mình được không.
Mình đang muốn học thêm về VBA để áp dụng trong các công việc của mình.

HieuCD · 14/10/17

hongtrang26 đã viết:
Cám ơn bạn rất nhiều mình áp dụng được vào việc tương tự rồi.
Cho mình hỏi thêm một bài ngược lại với bài này.
Vẫn là tìm kiếm nhiều điều kiện
nhưng là cứ điều kiện trùng thì ghi ra giá trị.
Hiện mình đang dùng công thức excel để tham chiếu ở cột K và L
nhưng khi dữ liệu lũy kế lên thì chạy hay đơ máy
Bạn xem giúp mình với.

Code chạy 2 sub

Mã:

Sub SanLuong()
Dim Arr(), dArr(), i As Long, j As Long, Key As String, S

With CreateObject("Scripting.Dictionary")
  With Sheets("san_luong")
    dArr = .Range("A7", .Range("A7").End(xlDown)).Resize(, 8).Value
    ReDim Arr(1 To UBound(dArr), 1 To 8)
  End With
  For i = 1 To UBound(dArr)
    Key = dArr(i, 1) & "#" & dArr(i, 2) & "#" & dArr(i, 3) & "#" & dArr(i, 4) _
                      & "#" & dArr(i, 6) & "#" & dArr(i, 7) & "#" & dArr(i, 8)
    If Not .Exists(Key) Then
      .Item(Key) = 1 & "_" & i
    Else
      .Item(Key) = .Item(Key) & "_" & i
    End If
    Key = dArr(i, 1) & "#" & dArr(i, 2) & "#" & dArr(i, 3) & "#" & dArr(i, 4) & "#" & dArr(i, 5)
    If Not .Exists(Key) Then .Add Key, i
  Next i

  With Sheets("quang_duong")
    dArr = .Range("A7", .Range("A7").End(xlDown)).Resize(, 9).Value
  End With
  For i = 1 To UBound(dArr)
    Key = dArr(i, 1) & "#" & dArr(i, 2) & "#" & dArr(i, 3) & "#" _
            & dArr(i, 4) & "#" & dArr(i, 5) & "#" & dArr(i, 6) & "#" & dArr(i, 7)
    If .Exists(Key) Then
      S = Split(.Item(Key), "_")
      For j = 1 To UBound(S)
        Arr(CLng(S(j)), 1) = Arr(CLng(S(j)), 1) + dArr(i, 8)
        Arr(CLng(S(j)), 2) = Arr(CLng(S(j)), 2) + dArr(i, 9)
      Next j
    End If
  Next i
 
  With Sheets("dau")
    dArr = .Range("A7", .Range("A7").End(xlDown)).Resize(, 11).Value
  End With
  For i = 1 To UBound(dArr)
    Key = dArr(i, 1) & "#" & dArr(i, 2) & "#" & dArr(i, 3) & "#" & dArr(i, 4) & "#" & dArr(i, 5)
    If .Exists(Key) Then
      S = .Item(Key)
      For j = 3 To 8
        Arr(S, j) = dArr(i, j + 3)
      Next j
    End If
  Next i
End With
Sheets("san_luong").Range("K7").Resize(UBound(Arr), 8) = Arr
End Sub

huonglien1901 · 14/10/17

HieuCD đã viết:

Code chạy 2 sub

Mã:

Sub SanLuong()
Dim Arr(), dArr(), i As Long, j As Long, Key As String, S

With CreateObject("Scripting.Dictionary")
  With Sheets("san_luong")
    dArr = .Range("A7", .Range("A7").End(xlDown)).Resize(, 8).Value
    ReDim Arr(1 To UBound(dArr), 1 To 8)
  End With
  For i = 1 To UBound(dArr)
    Key = dArr(i, 1) & "#" & dArr(i, 2) & "#" & dArr(i, 3) & "#" & dArr(i, 4) _
                      & "#" & dArr(i, 6) & "#" & dArr(i, 7) & "#" & dArr(i, 8)
    If Not .Exists(Key) Then
      .Item(Key) = 1 & "_" & i
    Else
      .Item(Key) = .Item(Key) & "_" & i
    End If
    Key = dArr(i, 1) & "#" & dArr(i, 2) & "#" & dArr(i, 3) & "#" & dArr(i, 4) & "#" & dArr(i, 5)
    If Not .Exists(Key) Then .Add Key, i
  Next i

  With Sheets("quang_duong")
    dArr = .Range("A7", .Range("A7").End(xlDown)).Resize(, 9).Value
  End With
  For i = 1 To UBound(dArr)
    Key = dArr(i, 1) & "#" & dArr(i, 2) & "#" & dArr(i, 3) & "#" _
            & dArr(i, 4) & "#" & dArr(i, 5) & "#" & dArr(i, 6) & "#" & dArr(i, 7)
    If .Exists(Key) Then
      S = Split(.Item(Key), "_")
      For j = 1 To UBound(S)
        Arr(CLng(S(j)), 1) = Arr(CLng(S(j)), 1) + dArr(i, 8)
        Arr(CLng(S(j)), 2) = Arr(CLng(S(j)), 2) + dArr(i, 9)
      Next j
    End If
  Next i
 
  With Sheets("dau")
    dArr = .Range("A7", .Range("A7").End(xlDown)).Resize(, 11).Value
  End With
  For i = 1 To UBound(dArr)
    Key = dArr(i, 1) & "#" & dArr(i, 2) & "#" & dArr(i, 3) & "#" & dArr(i, 4) & "#" & dArr(i, 5)
    If .Exists(Key) Then
      S = .Item(Key)
      For j = 3 To 8
        Arr(S, j) = dArr(i, j + 3)
      Next j
    End If
  Next i
End With
Sheets("san_luong").Range("K7").Resize(UBound(Arr), 8) = Arr
End Sub

Anh Hiếu có thể ghi chú trong code được không Anh?

Em cảm ơn Anh!

Chúc Anh ngày vui.

anhtuanle123 · 14/10/17

hongtrang26 đã viết:
Vẫn là tìm kiếm nhiều điều kiện
nhưng là cứ điều kiện trùng thì ghi ra giá trị.
Hiện mình đang dùng công thức excel để tham chiếu ở cột K và L
nhưng khi dữ liệu lũy kế lên thì chạy hay đơ máy
Bạn xem giúp mình với.

góp vui !
thuật toán đúng với cách chủ thớt miêu tả , với mỗi record của sheet san_luong duyệt qua danh sách quang_duong , nếu thấy trùng thì cộng dồn lại !
2 vòng lặp lồng nhau , vòng lặp ngoài cho san_luong , vòng lặp trong cho quang_duong
best regards

PacificPR · 14/10/17

HieuCD đã viết:

Code chạy 2 sub

Mã:

Sub SanLuong()
Dim Arr(), dArr(), i As Long, j As Long, Key As String, S

With CreateObject("Scripting.Dictionary")
  With Sheets("san_luong")
    dArr = .Range("A7", .Range("A7").End(xlDown)).Resize(, 8).Value
    ReDim Arr(1 To UBound(dArr), 1 To 8)
  End With
  For i = 1 To UBound(dArr)
    Key = dArr(i, 1) & "#" & dArr(i, 2) & "#" & dArr(i, 3) & "#" & dArr(i, 4) _
                      & "#" & dArr(i, 6) & "#" & dArr(i, 7) & "#" & dArr(i, 8)
    If Not .Exists(Key) Then
      .Item(Key) = 1 & "_" & i
    Else
      .Item(Key) = .Item(Key) & "_" & i
    End If
    Key = dArr(i, 1) & "#" & dArr(i, 2) & "#" & dArr(i, 3) & "#" & dArr(i, 4) & "#" & dArr(i, 5)
    If Not .Exists(Key) Then .Add Key, i
  Next i

  With Sheets("quang_duong")
    dArr = .Range("A7", .Range("A7").End(xlDown)).Resize(, 9).Value
  End With
  For i = 1 To UBound(dArr)
    Key = dArr(i, 1) & "#" & dArr(i, 2) & "#" & dArr(i, 3) & "#" _
            & dArr(i, 4) & "#" & dArr(i, 5) & "#" & dArr(i, 6) & "#" & dArr(i, 7)
    If .Exists(Key) Then
      S = Split(.Item(Key), "_")
      For j = 1 To UBound(S)
        Arr(CLng(S(j)), 1) = Arr(CLng(S(j)), 1) + dArr(i, 8)
        Arr(CLng(S(j)), 2) = Arr(CLng(S(j)), 2) + dArr(i, 9)
      Next j
    End If
  Next i
 
  With Sheets("dau")
    dArr = .Range("A7", .Range("A7").End(xlDown)).Resize(, 11).Value
  End With
  For i = 1 To UBound(dArr)
    Key = dArr(i, 1) & "#" & dArr(i, 2) & "#" & dArr(i, 3) & "#" & dArr(i, 4) & "#" & dArr(i, 5)
    If .Exists(Key) Then
      S = .Item(Key)
      For j = 3 To 8
        Arr(S, j) = dArr(i, j + 3)
      Next j
    End If
  Next i
End With
Sheets("san_luong").Range("K7").Resize(UBound(Arr), 8) = Arr
End Sub

Anh ơi sao cái Code này khó hiểu quá. Anh chú thích từng dòng lệnh được không anh

HieuCD · 14/10/17

huonglien1901 đã viết:
Anh Hiếu có thể ghi chú trong code được không Anh?
Em cảm ơn Anh!
Chúc Anh ngày vui.

PacificPR đã viết:
Anh ơi sao cái Code này khó hiểu quá. Anh chú thích từng dòng lệnh được không anh

thay đổi biến để dể đọc code hơn

Mã:

Sub SanLuong()
Dim Arr(), dArr(), i As Long, j As Long, Key1 As String, Key2 As String, S, ik

With CreateObject("Scripting.Dictionary")
  With Sheets("san_luong")
    dArr = .Range("A7", .Range("A7").End(xlDown)).Resize(, 8).Value 'Mang tao Key xác dinh dòng can ghi du lieu
    ReDim Arr(1 To UBound(dArr), 1 To 8) 'Mang ket qua
  End With
  For i = 1 To UBound(dArr)
    ' Key1 nhan dien thu tu dong ghi du lieu cot quangduong và he_so
    ' mot Key1 co the nam nhieu dòng o sheet sanluong
    Key1 = dArr(i, 1) & "#" & dArr(i, 2) & "#" & dArr(i, 3) & "#" & dArr(i, 4) _
                      & "#" & dArr(i, 6) & "#" & dArr(i, 7) & "#" & dArr(i, 8)
    If Not .Exists(Key1) Then
      'gán thu tu dong dau tien cua key vào Item
      '1 là gia tri tuong trung duoc them vào, de cho S = Split(.Item(Key), "_") luon luon là 1 mang
      .Item(Key1) = 1 & "_" & i
    Else
      .Item(Key1) = .Item(Key1) & "_" & i 'gán thu tu các dong ke tiep cua key vao Item
    End If
    ' Key2 nhan dien thu tu dong ghi du lieu cot Ma_lxe, ton_dau, phat_sinh ...
    ' chi lay dong dau tien cua key, khong lay các dòng sau, nhàm loai trùng
    Key2 = dArr(i, 1) & "#" & dArr(i, 2) & "#" & dArr(i, 3) & "#" & dArr(i, 4) & "#" & dArr(i, 5)
    If Not .Exists(Key2) Then .Add Key2, i 'gán thu tu dong dau tien cua key vào Item
  Next i

  With Sheets("quang_duong")
    dArr = .Range("A7", .Range("A7").End(xlDown)).Resize(, 9).Value
  End With
  For i = 1 To UBound(dArr)
    ' Key1 nhan dien thu tu dong ghi du lieu cot quangduong và he_so
    Key1 = dArr(i, 1) & "#" & dArr(i, 2) & "#" & dArr(i, 3) & "#" _
            & dArr(i, 4) & "#" & dArr(i, 5) & "#" & dArr(i, 6) & "#" & dArr(i, 7)
    If .Exists(Key1) Then 'Neu co key tuong ung o sheet san_luong (da luu vao Dic)
      S = Split(.Item(Key1), "_") 'Mang cac thu tu dong sheet san_luong da ghi vao Item, s(0)=1 khong su dung
      For j = 1 To UBound(S)
        'S(j) là thu tu dong sheet san_luong, CLng(S(j)) chuyen chuoi thành só
        ' cong dòn các dòng có cùng Key
        Arr(CLng(S(j)), 1) = Arr(CLng(S(j)), 1) + dArr(i, 8)
        Arr(CLng(S(j)), 2) = Arr(CLng(S(j)), 2) + dArr(i, 9)
      Next j
    End If
  Next i

  With Sheets("dau")
    dArr = .Range("A7", .Range("A7").End(xlDown)).Resize(, 11).Value
  End With
  For i = 1 To UBound(dArr)
    Key2 = dArr(i, 1) & "#" & dArr(i, 2) & "#" & dArr(i, 3) & "#" & dArr(i, 4) & "#" & dArr(i, 5)
    If .Exists(Key2) Then
      ik = .Item(Key2) ' thu tu dòng sheet san_luong
      For j = 3 To 8 'gán ket qua vào các cot, dòng ik
        Arr(ik, j) = dArr(i, j + 3)
      Next j
    End If
  Next i
End With
Sheets("san_luong").Range("K7").Resize(UBound(Arr), 8) = Arr
End Sub

Binbo2020 · 15/10/17

anhtuanle123 đã viết:
góp vui !
thuật toán đúng với cách chủ thớt miêu tả , với mỗi record của sheet san_luong duyệt qua danh sách quang_duong , nếu thấy trùng thì cộng dồn lại !
2 vòng lặp lồng nhau , vòng lặp ngoài cho san_luong , vòng lặp trong cho quang_duong
best regards

Hi cám ơn bạn rất nhiều, xem code của bạn học thêm được điều nữa là
gộp các đoạn sub khác nhau cho một nút bấm, cái này chưa biết.
toàn đi học mót các sub trên diễn đàn nên có nhiều sub khác nhau
trong một bảng bao nhiêu sub làm bấy nhiêu nút bấm.

Binbo2020 · 15/10/17

HieuCD đã viết:

thay đổi biến để dể đọc code hơn

Mã:

Sub SanLuong()
Dim Arr(), dArr(), i As Long, j As Long, Key1 As String, Key2 As String, S, ik

With CreateObject("Scripting.Dictionary")
  With Sheets("san_luong")
    dArr = .Range("A7", .Range("A7").End(xlDown)).Resize(, 8).Value 'Mang tao Key xác dinh dòng can ghi du lieu
    ReDim Arr(1 To UBound(dArr), 1 To 8) 'Mang ket qua
  End With
  For i = 1 To UBound(dArr)
    ' Key1 nhan dien thu tu dong ghi du lieu cot quangduong và he_so
    ' mot Key1 co the nam nhieu dòng o sheet sanluong
    Key1 = dArr(i, 1) & "#" & dArr(i, 2) & "#" & dArr(i, 3) & "#" & dArr(i, 4) _
                      & "#" & dArr(i, 6) & "#" & dArr(i, 7) & "#" & dArr(i, 8)
    If Not .Exists(Key1) Then
      'gán thu tu dong dau tien cua key vào Item
      '1 là gia tri tuong trung duoc them vào, de cho S = Split(.Item(Key), "_") luon luon là 1 mang
      .Item(Key1) = 1 & "_" & i
    Else
      .Item(Key1) = .Item(Key1) & "_" & i 'gán thu tu các dong ke tiep cua key vao Item
    End If
    ' Key2 nhan dien thu tu dong ghi du lieu cot Ma_lxe, ton_dau, phat_sinh ...
    ' chi lay dong dau tien cua key, khong lay các dòng sau, nhàm loai trùng
    Key2 = dArr(i, 1) & "#" & dArr(i, 2) & "#" & dArr(i, 3) & "#" & dArr(i, 4) & "#" & dArr(i, 5)
    If Not .Exists(Key2) Then .Add Key2, i 'gán thu tu dong dau tien cua key vào Item
  Next i

  With Sheets("quang_duong")
    dArr = .Range("A7", .Range("A7").End(xlDown)).Resize(, 9).Value
  End With
  For i = 1 To UBound(dArr)
    ' Key1 nhan dien thu tu dong ghi du lieu cot quangduong và he_so
    Key1 = dArr(i, 1) & "#" & dArr(i, 2) & "#" & dArr(i, 3) & "#" _
            & dArr(i, 4) & "#" & dArr(i, 5) & "#" & dArr(i, 6) & "#" & dArr(i, 7)
    If .Exists(Key1) Then 'Neu co key tuong ung o sheet san_luong (da luu vao Dic)
      S = Split(.Item(Key1), "_") 'Mang cac thu tu dong sheet san_luong da ghi vao Item, s(0)=1 khong su dung
      For j = 1 To UBound(S)
        'S(j) là thu tu dong sheet san_luong, CLng(S(j)) chuyen chuoi thành só
        ' cong dòn các dòng có cùng Key
        Arr(CLng(S(j)), 1) = Arr(CLng(S(j)), 1) + dArr(i, 8)
        Arr(CLng(S(j)), 2) = Arr(CLng(S(j)), 2) + dArr(i, 9)
      Next j
    End If
  Next i

  With Sheets("dau")
    dArr = .Range("A7", .Range("A7").End(xlDown)).Resize(, 11).Value
  End With
  For i = 1 To UBound(dArr)
    Key2 = dArr(i, 1) & "#" & dArr(i, 2) & "#" & dArr(i, 3) & "#" & dArr(i, 4) & "#" & dArr(i, 5)
    If .Exists(Key2) Then
      ik = .Item(Key2) ' thu tu dòng sheet san_luong
      For j = 3 To 8 'gán ket qua vào các cot, dòng ik
        Arr(ik, j) = dArr(i, j + 3)
      Next j
    End If
  Next i
End With
Sheets("san_luong").Range("K7").Resize(UBound(Arr), 8) = Arr
End Sub

Bạn ơi làm ơn xem lại giúp mình một chút.
ở phần code sheet quang_duong.
Bạn đang để cộng dồn các dòng có cùng key
Mục tiêu của mình là cứ cùng key thì điền giá trị thôi.
Vì khi nhập liệu, người làm có thể vô tình nhập thành 2 lần, khi đó 2 giá trị là như nhau
Cùng thời gian, kho, vị trí, nơi trả thì chỉ có một quãng đường, một hệ số thôi.
Xin lỗi vì đã không ghi rõ hết yêu cầu.
Ngoài ra khi dòng dữ liệu không liên tục
Kết quả trả ra chưa chính xác.
có cách nào xử lý được không

HieuCD · 15/10/17

hongtrang26 đã viết:
Bạn ơi làm ơn xem lại giúp mình một chút.
ở phần code sheet quang_duong.
Bạn đang để cộng dồn các dòng có cùng key
Mục tiêu của mình là cứ cùng key thì điền giá trị thôi.
Vì khi nhập liệu, người làm có thể vô tình nhập thành 2 lần, khi đó 2 giá trị là như nhau
Cùng thời gian, kho, vị trí, nơi trả thì chỉ có một quãng đường, một hệ số thôi.
Xin lỗi vì đã không ghi rõ hết yêu cầu.
Ngoài ra khi dòng dữ liệu không liên tục
Kết quả trả ra chưa chính xác.
có cách nào xử lý được không

Sheet quang_duong có 2 dòng 15 và 20, bạn chọn dòng nào
code có ghi chú cách chọn dòng du lieu tùy bạn xử lý

Mã:

Sub SanLuong()
Dim Arr(), dArr(), i As Long, j As Long, Key1 As String, Key2 As String, S, ik

With CreateObject("Scripting.Dictionary")
  With Sheets("san_luong")
    dArr = .Range("A7", .Range("A7").End(xlDown)).Resize(, 8).Value 'Mang tao Key xác dinh dòng can ghi du lieu
    ReDim Arr(1 To UBound(dArr), 1 To 8) 'Mang ket qua
  End With
  For i = 1 To UBound(dArr)
    ' Key1 nhan dien thu tu dong ghi du lieu cot quangduong và he_so
    ' mot Key1 co the nam nhieu dòng o sheet sanluong
    Key1 = dArr(i, 1) & "#" & dArr(i, 2) & "#" & dArr(i, 3) & "#" & dArr(i, 4) _
                      & "#" & dArr(i, 6) & "#" & dArr(i, 7) & "#" & dArr(i, 8)
    If Not .Exists(Key1) Then
      'gán thu tu dong dau tien cua key vào Item
      '1 là gia tri tuong trung duoc them vào, de cho S = Split(.Item(Key), "_") luon luon là 1 mang
      .Item(Key1) = 1 & "_" & i
    Else
      .Item(Key1) = .Item(Key1) & "_" & i 'gán thu tu các dong ke tiep cua key vao Item
    End If
    ' Key2 nhan dien thu tu dong ghi du lieu cot Ma_lxe, ton_dau, phat_sinh ...
    ' chi lay dong dau tien cua key, khong lay các dòng sau, nhàm loai trùng
    Key2 = dArr(i, 1) & "#" & dArr(i, 2) & "#" & dArr(i, 3) & "#" & dArr(i, 4) & "#" & dArr(i, 5)
    If Not .Exists(Key2) Then .Add Key2, i 'gán thu tu dong dau tien cua key vào Item
  Next i

  With Sheets("quang_duong")
    dArr = .Range("A7", .Range("A7").End(xlDown)).Resize(, 9).Value
  End With
  For i = 1 To UBound(dArr)
    ' Key1 nhan dien thu tu dong ghi du lieu cot quangduong và he_so
    Key1 = dArr(i, 1) & "#" & dArr(i, 2) & "#" & dArr(i, 3) & "#" _
            & dArr(i, 4) & "#" & dArr(i, 5) & "#" & dArr(i, 6) & "#" & dArr(i, 7)
    If .Exists(Key1) Then 'Neu co key tuong ung o sheet san_luong (da luu vao Dic)
      S = Split(.Item(Key1), "_") 'Mang cac thu tu dong sheet san_luong da ghi vao Item, s(0)=1 khong su dung
      For j = 1 To UBound(S)
        'S(j) là thu tu dong sheet san_luong, CLng(S(j)) chuyen chuoi thành só
        Arr(CLng(S(j)), 1) = dArr(i, 8)
        Arr(CLng(S(j)), 2) = dArr(i, 9)
      Next j
      .Remove (Key1) 'remove key trong Dic, chi lay du lieu dau tien. Bo dong nay se lay du lieu cuoi cùng
    End If
  Next i

  With Sheets("dau")
    dArr = .Range("A7", .Range("A7").End(xlDown)).Resize(, 11).Value
  End With
  For i = 1 To UBound(dArr)
    Key2 = dArr(i, 1) & "#" & dArr(i, 2) & "#" & dArr(i, 3) & "#" & dArr(i, 4) & "#" & dArr(i, 5)
    If .Exists(Key2) Then
      ik = .Item(Key2) ' thu tu dòng sheet san_luong
      For j = 3 To 8 'gán ket qua vào các cot, dòng ik
        Arr(ik, j) = dArr(i, j + 3)
      Next j
    End If
  Next i
End With
Sheets("san_luong").Range("K7").Resize(UBound(Arr), 8) = Arr
End Sub

Nhờ trợ giúp code tham chiếu và điền giá trị không trùng theo điều kiện (1 người xem)

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

Thành viên tích cực

File đính kèm

Thành viên thường trực

File đính kèm

Thành viên tích cực

Thành viên thường trực

File đính kèm

Thành viên tích cực

File đính kèm

Cạo Rồi Khỏi Gội

Thành viên tích cực

Chuyên gia GPE

GPE là ngôi nhà thứ 2 của tôi!!!

Thành viên thường trực

File đính kèm

Thành viên mới

Chuyên gia GPE

Thành viên tích cực

Thành viên tích cực

Chuyên gia GPE

Đếm ngược thời gian