Đối chiếu hàng tồn kho theo mã ,xác định các chênh lệch và đánh dấu

Nguyễn Hồng Quang · 11/5/19

Em có 1 bảng tính đang đối chiếu dữ liệu, em cần đánh dấu vào cột G các dòng mà có các ô ở cột E, F xuất hiện giá trị False. Chi tiết em đã ghi chú trong bảng tính. Rất mong các anh , chị và các bạn giúp đỡ
Em xin cảm ơn

Nguyễn Hồng Quang · 15/5/19

HieuCD đã viết:

Kiểm tra lại

Mã:

Dim Res(), sArr2(), k As Long, j2 As Long
Sub RoundedRectangle6_Click()
  Dim sArr1(), tmp As String, dk As Boolean
  Dim i As Long, j As Long, q As Long, sRow As Long
  Dim i2 As Long, n2 As Long, q2 As Long

  With Sheets("Data")
    If .Range("A2").Value <= .Range("D2").Value Then
      sArr1 = .Range("A2:C" & .Range("A" & Rows.Count).End(xlUp).Row).Value
      sArr2 = .Range("D2:F" & .Range("D" & Rows.Count).End(xlUp).Row).Value
      j = 1: j2 = 4
    Else
      sArr2 = .Range("A2:C" & .Range("A" & Rows.Count).End(xlUp).Row).Value
      sArr1 = .Range("D2:F" & .Range("D" & Rows.Count).End(xlUp).Row).Value
      j = 4: j2 = 1
    End If
  End With
  Application.ScreenUpdating = False
  sRow = UBound(sArr1)
  ReDim Res(1 To sRow + UBound(sArr2), 1 To 6)
  k = 0: n2 = 1
  For i = 1 To sRow
    If Len(sArr1(i, 1)) Then
      k = k + 1
      Res(k, j) = sArr1(i, 1)
      Res(k, j + 1) = sArr1(i, 2)
      Res(k, j + 2) = sArr1(i, 3)
      tmp = "zzz"
      For q = i + 1 To sRow
        If Len(sArr1(q, 1)) Then tmp = sArr1(q, 1): Exit For
      Next q
      If tmp <> sArr1(i, 1) Then
        dk = False
        For i2 = n2 To UBound(sArr2)
          If sArr2(i2, 1) = sArr1(i, 1) And sArr2(i2, 2) = sArr1(i, 2) And sArr2(i2, 3) = sArr1(i, 3) Then
            If dk = True Then k = k + 1
            Call GanKetQua(i2)
            sArr2(i2, 1) = ""
            dk = True
          End If
          If sArr2(i2, 1) = tmp Then
            For q2 = n2 To i2 - 1
              If Len(sArr2(q2, 1)) Then
                If sArr2(q2, 1) <> sArr1(i, 1) Then k = k + 1
                Call GanKetQua(q2)
              End If
            Next q2
            n2 = i2:        Exit For
          End If
        Next i2
      Else
        If sArr2(n2, 1) = tmp Then
          Call GanKetQua(n2)
          n2 = n2 + 1
        End If
      End If
    End If
  Next i
  With Sheets("KQ")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    i2 = .Range("D" & Rows.Count).End(xlUp).Row
    If i2 > i Then i = i2
    If i > 1 Then .Range("A2:F" & i).ClearContents
    .Range("A2").Resize(k, 6) = Res
  End With
  Application.ScreenUpdating = True
End Sub

Private Sub GanKetQua(ByVal m As Long)
  Res(k, j2) = sArr2(m, 1)
  Res(k, j2 + 1) = sArr2(m, 2)
  Res(k, j2 + 2) = sArr2(m, 3)
End Sub

Em cảm ơn anh. Code của anh ra đúng với kết quả mong muốn ở bài này rồi ạ.
Nhưng khi cũng dạng dữ liệu này y hệt. Dữ liệu tăng lên tầm 18.000 dòng thì lại không được. Nhất là khi xuất hiện tình huống so le mã là bị sai
(cụ thể là KQ chạy code so với KQ mong muốn; bắt đầu không đúng từ dòng 317 trong file này anh à)
Tất cả dữ liệu em đã sort rồi. Nên khi chạy code Em chỉ mong muốn so khớp 2 cột với nhau thôi, không cần phải đi tìm các mã để khớp với nhau ở các vùng dưới nữa anh à

HieuCD · 16/5/19

Nguyễn Hồng Quang đã viết:
Em cảm ơn anh. Code của anh ra đúng với kết quả mong muốn ở bài này rồi ạ.
Nhưng khi cũng dạng dữ liệu này y hệt. Dữ liệu tăng lên tầm 18.000 dòng thì lại không được. Nhất là khi xuất hiện tình huống so le mã là bị sai
(cụ thể là KQ chạy code so với KQ mong muốn; bắt đầu không đúng từ dòng 317 trong file này anh à)
Tất cả dữ liệu em đã sort rồi. Nên khi chạy code Em chỉ mong muốn so khớp 2 cột với nhau thôi, không cần phải đi tìm các mã để khớp với nhau ở các vùng dưới nữa anh à

Kết quả mong muốn làm sao có vậy? Có thể phải xét thêm vài cột điều kiện mà trong file không có

Nguyễn Hồng Quang · 16/5/19

HieuCD đã viết:
Kết quả mong muốn làm sao có vậy? Có thể phải xét thêm vài cột điều kiện mà trong file không có

Cảm ơn anh đã hỗ trợ em trong thời gian qua. Em cũng không biết diễn đạt sao cho ra vấn đề. Có lẽ để em làm 1 clip mô tả lại quá trình em làm thủ công. Và gửi lại sau anh nhé. Chúc anh sức khỏe dồi dào và gặp nhiều niềm vui.

HieuCD · 17/5/19

Nguyễn Hồng Quang đã viết:
Cảm ơn anh đã hỗ trợ em trong thời gian qua. Em cũng không biết diễn đạt sao cho ra vấn đề. Có lẽ để em làm 1 clip mô tả lại quá trình em làm thủ công. Và gửi lại sau anh nhé. Chúc anh sức khỏe dồi dào và gặp nhiều niềm vui.

Dữ liệu phải sort theo ưu tiên: Phiếu, Mã
Dữ liệu không có dòng trống
Kết quả mong muốn của bạn thiếu nhiều dòng
Kiểm tra code

Mã:

  Dim Res(), sArr(), sArr2()
  Dim Phieu As String, Ma As String, sRow As Long, sRow2 As Long
  Dim i As Long, i2 As Long, n2 As Long, k As Long
 
Sub Button1_Click1()
  With Sheets("Data")
      sArr = .Range("A2:C" & .Range("A" & Rows.Count).End(xlUp).Row + 1).Value
      sArr2 = .Range("D2:F" & .Range("D" & Rows.Count).End(xlUp).Row).Value
  End With
  Application.ScreenUpdating = False
  sRow = UBound(sArr) - 1
  sRow2 = UBound(sArr2)
  ReDim Res(1 To sRow + sRow2, 1 To 6)
  k = 0: n2 = 1
  For i = 1 To sRow
    Phieu = UCase(sArr(i, 2))
    If Phieu > UCase(sArr2(n2, 2)) Then
      Call Nho
    ElseIf Phieu = UCase(sArr2(n2, 2)) Then
      Call Bang
    Else
      Call Lon
    End If
    If k = UBound(Res) - 1 Then Exit For
  Next i
  With Sheets("KQ")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    i2 = .Range("D" & Rows.Count).End(xlUp).Row
    If i2 > i Then i = i2
    If i > 1 Then .Range("A2:F" & i).ClearContents
    .Range("A2").Resize(k, 6) = Res
  End With
  Application.ScreenUpdating = True
End Sub
Private Sub Bang()
      Ma = sArr(i, 1)
      For i2 = n2 To sRow2
        If UCase(sArr2(i2, 2)) = Phieu Then
          If Len(sArr2(i2, 1)) > 0 Then
            If Ma > sArr2(i2, 1) Then
              k = k + 1: Call GanKetQua2(i2)
              sArr2(i2, 1) = ""
            ElseIf Ma = sArr2(i2, 1) Then
              k = k + 1:  Call GanKetQua1(i)
              If sArr2(i2, 1) = sArr(i, 1) And UCase(sArr2(i2, 2)) = UCase(sArr(i, 2)) And sArr2(i2, 3) = sArr(i, 3) Then
                Call GanKetQua2(i2)
                sArr2(i2, 1) = "": Exit For
              End If
            Else
              Exit For
            End If
          End If
        Else
          Exit For
        End If
      Next i2
      If Phieu <> UCase(sArr(i + 1, 2)) Then
        For i2 = n2 To sRow2
          If UCase(sArr2(i2, 2)) = Phieu Then
            If Len(sArr2(i2, 1)) > 0 Then
              k = k + 1: Call GanKetQua2(i2)
            End If
          Else
            n2 = i2: Exit For
          End If
        Next i2
      End If
End Sub
Private Sub Lon()
  Dim ik As Long
  For ik = i To UBound(sArr1)
    If Phieu = sArr1(ik, 2) Then
      If Len(sArr1(ik, 1)) > 0 Then
        k = k + 1
        Call GanKetQua1(ik)
      End If
    Else
      i = ik - 1: Exit For
    End If
  Next ik
End Sub
Private Sub Nho()
  For i2 = n2 To UBound(sArr2)
    If Phieu > sArr2(i2, 2) Then
      If Len(sArr2(i2, 1)) > 0 Then
        k = k + 1
        Call GanKetQua2(i2)
      End If
    Else
      n2 = i2: Exit For
    End If
  Next i2
End Sub
Private Sub GanKetQua1(ByVal m As Long)
  Res(k, 1) = sArr(m, 1)
  Res(k, 2) = sArr(m, 2)
  Res(k, 3) = sArr(m, 3)
End Sub
Private Sub GanKetQua2(ByVal m As Long)
  Res(k, 4) = sArr2(m, 1)
  Res(k, 5) = sArr2(m, 2)
  Res(k, 6) = sArr2(m, 3)
End Sub

Nguyễn Hồng Quang · 17/5/19

HieuCD đã viết:

Dữ liệu phải sort theo ưu tiên: Phiếu, Mã
Dữ liệu không có dòng trống
Kết quả mong muốn của bạn thiếu nhiều dòng
Kiểm tra code

Mã:

  Dim Res(), sArr(), sArr2()
  Dim Phieu As String, Ma As String, sRow As Long, sRow2 As Long
  Dim i As Long, i2 As Long, n2 As Long, k As Long

Sub Button1_Click1()
  With Sheets("Data")
      sArr = .Range("A2:C" & .Range("A" & Rows.Count).End(xlUp).Row + 1).Value
      sArr2 = .Range("D2:F" & .Range("D" & Rows.Count).End(xlUp).Row).Value
  End With
  Application.ScreenUpdating = False
  sRow = UBound(sArr) - 1
  sRow2 = UBound(sArr2)
  ReDim Res(1 To sRow + sRow2, 1 To 6)
  k = 0: n2 = 1
  For i = 1 To sRow
    Phieu = UCase(sArr(i, 2))
    If Phieu > UCase(sArr2(n2, 2)) Then
      Call Nho
    ElseIf Phieu = UCase(sArr2(n2, 2)) Then
      Call Bang
    Else
      Call Lon
    End If
    If k = UBound(Res) - 1 Then Exit For
  Next i
  With Sheets("KQ")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    i2 = .Range("D" & Rows.Count).End(xlUp).Row
    If i2 > i Then i = i2
    If i > 1 Then .Range("A2:F" & i).ClearContents
    .Range("A2").Resize(k, 6) = Res
  End With
  Application.ScreenUpdating = True
End Sub
Private Sub Bang()
      Ma = sArr(i, 1)
      For i2 = n2 To sRow2
        If UCase(sArr2(i2, 2)) = Phieu Then
          If Len(sArr2(i2, 1)) > 0 Then
            If Ma > sArr2(i2, 1) Then
              k = k + 1: Call GanKetQua2(i2)
              sArr2(i2, 1) = ""
            ElseIf Ma = sArr2(i2, 1) Then
              k = k + 1:  Call GanKetQua1(i)
              If sArr2(i2, 1) = sArr(i, 1) And UCase(sArr2(i2, 2)) = UCase(sArr(i, 2)) And sArr2(i2, 3) = sArr(i, 3) Then
                Call GanKetQua2(i2)
                sArr2(i2, 1) = "": Exit For
              End If
            Else
              Exit For
            End If
          End If
        Else
          Exit For
        End If
      Next i2
      If Phieu <> UCase(sArr(i + 1, 2)) Then
        For i2 = n2 To sRow2
          If UCase(sArr2(i2, 2)) = Phieu Then
            If Len(sArr2(i2, 1)) > 0 Then
              k = k + 1: Call GanKetQua2(i2)
            End If
          Else
            n2 = i2: Exit For
          End If
        Next i2
      End If
End Sub
Private Sub Lon()
  Dim ik As Long
  For ik = i To UBound(sArr1)
    If Phieu = sArr1(ik, 2) Then
      If Len(sArr1(ik, 1)) > 0 Then
        k = k + 1
        Call GanKetQua1(ik)
      End If
    Else
      i = ik - 1: Exit For
    End If
  Next ik
End Sub
Private Sub Nho()
  For i2 = n2 To UBound(sArr2)
    If Phieu > sArr2(i2, 2) Then
      If Len(sArr2(i2, 1)) > 0 Then
        k = k + 1
        Call GanKetQua2(i2)
      End If
    Else
      n2 = i2: Exit For
    End If
  Next i2
End Sub
Private Sub GanKetQua1(ByVal m As Long)
  Res(k, 1) = sArr(m, 1)
  Res(k, 2) = sArr(m, 2)
  Res(k, 3) = sArr(m, 3)
End Sub
Private Sub GanKetQua2(ByVal m As Long)
  Res(k, 4) = sArr2(m, 1)
  Res(k, 5) = sArr2(m, 2)
  Res(k, 6) = sArr2(m, 3)
End Sub

Cảm ơn anh; em sẽ kiểm tra rồi báo anh sau.

Đối chiếu hàng tồn kho theo mã ,xác định các chênh lệch và đánh dấu

Nguyễn Hồng Quang

Thành viên GPE Hà Nội

File đính kèm

Nguyễn Hồng Quang

Thành viên GPE Hà Nội

File đính kèm

HieuCD

Chuyên gia GPE

Nguyễn Hồng Quang

Thành viên GPE Hà Nội

HieuCD

Chuyên gia GPE

Nguyễn Hồng Quang

Thành viên GPE Hà Nội

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

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