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

Liên hệ QC
Nguyễn Hồng Quang

Nguyễn Hồng Quang

Thành viên GPE Hà Nội
Tham gia
8/6/07
Bài viết
1,203
Được thích
876
Điểm
1,468
Tuổi
39
Nơi ở
Hà Nội
Giới tính
Nam
Nghề nghiệp
Kế toán
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
 

File đính kèm

  • Đánh dấu các dòng lỗi.xlsm
    537.3 KB · Đọc: 29
Sắp xếp theo thời gian sắp xếp theo bầu chọn
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
Nhấp chuột vào đây để mở rộng...
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 à
 

File đính kèm

  • so sanh 3.xlsb
    926 KB · Đọc: 12
Lần chỉnh sửa cuối:
Upvote 0
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 à
Nhấp chuột vào đây để mở rộng...
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ó
 
Upvote 0
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ó
Nhấp chuột vào đây để mở rộng...
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.
 
Upvote 0
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.
Nhấp chuột vào đây để mở rộng...
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
 
Upvote 0
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
Nhấp chuột vào đây để mở rộng...
Cảm ơn anh; em sẽ kiểm tra rồi báo anh sau.
 
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

LuuAnh980
    • Thích
    • Cười
Vấn đề viết tắt trong Diễn Đàn.
2
Trả lời
32
Đọc
353
NCSCVN
NCSCVN
L
Tạo hàm Round cho nhiều dòng
Trả lời
14
Đọc
6K
KenJayce
K
N
Giải pháp nào để gỡ bỏ hàm Round (là hàm ngoài cùng) trong tất cả các ô trong bảng?
Trả lời
8
Đọc
4K
KenJayce
K
T
Tổng hợp từ Sheet1 qua Sheet2
Trả lời
7
Đọc
117
thaiquy7
T
ann266
    • Cười
Kế toán kho F&B
2
Trả lời
22
Đọc
253
le_vis
L
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