Xin giúp đỡ: Code tìm giá trị tương ứng giữa 2 mảng dữ liệu trong excel

Liên hệ QC
T

tunglinhmot

Thành viên chính thức
Tham gia
17/5/17
Bài viết
59
Được thích
6
Giới tính
Nam
Chào các anh chị trong diễn đàn, em có một bài toán như sau cần giúp đỡ ạ.
Có 2 file dữ liệu A và B, mỗi file có 3 cột giá trị . Trong đó có file A là chuẩn với 3 cột giá trị mà các giá trị ở từng hàng đã đc sắp xếp theo thứ tự chuẩn. File còn lại là file B chưa đc sắp xếp và em muốn tất cả những hàng của file B nếu tìm thấy giá trị theo hàng giống hàng nào đó ở file A (ko quan tâm thứ tự )thì sẽ phải sắp xếp lại thứ tự theo hàng giống file A.
Có thể mở rộng thêm là thay đổi đc thứ tự của giá trị của các cột giá trị khác gắn với giá trị đang mang đi so sánh với file A của file B .
Em xin cảm ơn ạ.
 
Sắp xếp theo thời gian sắp xếp theo bầu chọn
tunglinhmot đã viết:
Chào các anh chị trong diễn đàn, em có một bài toán như sau cần giúp đỡ ạ.
Có 2 file dữ liệu A và B, mỗi file có 3 cột giá trị . Trong đó có file A là chuẩn với 3 cột giá trị mà các giá trị ở từng hàng đã đc sắp xếp theo thứ tự chuẩn. File còn lại là file B chưa đc sắp xếp và em muốn tất cả những hàng của file B nếu tìm thấy giá trị theo hàng giống hàng nào đó ở file A (ko quan tâm thứ tự )thì sẽ phải sắp xếp lại thứ tự theo hàng giống file A.
Có thể mở rộng thêm là thay đổi đc thứ tự của giá trị của các cột giá trị khác gắn với giá trị đang mang đi so sánh với file A của file B .
Em xin cảm ơn ạ.
Nhấp chuột vào đây để mở rộng...
Không thấy file A và B nên thua, khỏi mở rộng - mở hẹp.
 
Upvote 0
VetMini đã viết:
Thắc mắc:
Quý vị đăng bài có bao giờ xem lại để biết mình đã đăng thế nào, và khả năng người đọc có hiểu mình hỏi gì hay không vậy?
Nhấp chuột vào đây để mở rộng...
Em đã xem lại và cũng cố gắng trình bày hết vấn đề của mình rồi bác ạ. Còn chỗ nào chưa rõ bác bảo em với ạ.
 
Upvote 0
tunglinhmot đã viết:
Em quên mất, 2 file mẫu A và B đây ạ, nhờ bác xem giúp ạ.
Nhấp chuột vào đây để mở rộng...
Copy code vào module của file B, chạy sub XYZ
Mã: 
Option Explicit
Sub XYZ()
  Dim wb As Workbook, dic As Object, arr(), res(), a
  Dim sRow&, sCol&, i&, j&, jCol&, k&, key$
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  On Error GoTo Thoat
  Set wb = Workbooks.Open(ThisWorkbook.Path & "\FILE A.xlsx")
  i = wb.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
  If i < 2 Then GoTo Thoat
  arr = wb.Sheets("Sheet1").Range("A2:C" & i).Value
  wb.Close False: Set wb = Nothing
 
  Call AddDic(dic, arr)
  With ThisWorkbook.Sheets("sheet1")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    jCol = .Range("AAA3").End(xlToLeft).Column
    If i < 3 Or jCol < 3 Then GoTo Thoat
    arr = .Range("A3", .Cells(i, jCol)).Value
    sCol = Int(UBound(arr, 2) / 3) * 3
  End With
  sRow = UBound(arr)
  ReDim res(1 To sRow, 1 To sCol)
  For i = 1 To sRow
    key = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)
    If dic.exists(key) Then a = dic(key) Else a = Array(, 1, 2, 3)
    For k = 1 To sCol Step 3
      For j = 1 To 3
        res(i, k + j - 1) = arr(i, k + a(j) - 1)
      Next j
    Next k
  Next i
  ThisWorkbook.Sheets("sheet1").Range("A3").Resize(sRow, sCol) = res

  If sRow = -1 Then
Thoat:
    MsgBox ("Khong co du lieu!")
  End If
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

Private Sub AddDic(dic, arr)
  Dim a, sR&, i&, j&, key$
  Set dic = CreateObject("scripting.dictionary")
  a = Array(1, 2, 3, 1, 3, 2, 2, 1, 3, 2, 3, 1, 3, 1, 2, 3, 2, 1) 'Hoan Vi
  sR = UBound(arr)
  For i = 1 To sR
    For j = 0 To 17 Step 3
      key = arr(i, a(j)) & "|" & arr(i, a(j + 1)) & "|" & arr(i, a(j + 2))
      If dic.exists(key) = False Then dic(key) = Array(, a(j), a(j + 1), a(j + 2))
    Next j
  Next i
End Sub
 

File đính kèm

  • FILE B.xlsm
    23.6 KB · Đọc: 17
Upvote 0
Xài đỡ cái này:
Có 2 sheet: A và B
A là sheet trong file A
B là sheet trong file B
Chạy code xong copy sheet B qua file B là được.
PHP: 
Option Explicit
Sub sapxep()
Dim lrA&, lrB&, i&, j&, k&, c, rngA, rngB
Dim id As String, dic As Object, key As String
Dim wsA As Worksheet, wsB As Worksheet, arr()
Set dic = CreateObject("Scripting.dictionary")
Set wsA = Worksheets("A"): Set wsB = Worksheets("B")
lrA = wsA.Cells(Rows.Count, "A").End(xlUp).Row
lrB = wsB.Cells(Rows.Count, "A").End(xlUp).Row
rngA = wsA.Range("A2:C" & lrA).Value
rngB = wsB.Range("A3:J" & lrB).Value
ReDim arr(1 To lrA + lrB, 1 To 9)
With WorksheetFunction
For i = 1 To lrA - 1
    id = rngA(i, 1) & "|" & rngA(i, 2) & "|" & rngA(i, 3)
    c = .CountIfs(wsB.Range("A3:A" & lrB), rngA(i, 1), wsB.Range("B3:B" & lrB), rngA(i, 2), _
    wsB.Range("C3:C" & lrB), rngA(i, 3))
    If Not dic.exists(id) Then dic.Add id, c
Next
For i = 1 To UBound(rngB)
    If .CountIfs(wsA.Range("A2:A" & lrA), rngB(i, 1), wsA.Range("B2:B" & lrA), _
    rngB(i, 2), wsA.Range("C2:C" & lrA), rngB(i, 3)) = 0 Then
        k = k + 1
        rngB(i, 10) = "x"
        For j = 1 To 9
            arr(lrA - 1 + k, j) = rngB(i, j)
        Next
    End If
Next
k = 0
For i = 1 To lrA - 1
    For j = 1 To UBound(rngB)
        key = rngA(i, 1) & "|" & rngA(i, 2) & "|" & rngA(i, 3)
        id = rngB(j, 1) & "|" & rngB(j, 2) & "|" & rngB(j, 3)
        If key = id And dic(key) > 0 And rngB(j, 10) <> "x" Then
            rngB(j, 10) = "x"
            For k = 1 To 9
                arr(i, k) = rngB(j, k)
            Next
            dic(key) = dic(key) - 1
            GoTo z:
        End If
    Next
z:
Next
wsB.Range("A3").Resize(UBound(arr), 9).Value = arr
End With
End Sub
 

File đính kèm

  • FILE A.xlsm
    31 KB · Đọc: 13
Upvote 0
HieuCD đã viết:
Copy code vào module của file B, chạy sub XYZ
Mã: 
Option Explicit
Sub XYZ()
  Dim wb As Workbook, dic As Object, arr(), res(), a
  Dim sRow&, sCol&, i&, j&, jCol&, k&, key$
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  On Error GoTo Thoat
  Set wb = Workbooks.Open(ThisWorkbook.Path & "\FILE A.xlsx")
  i = wb.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
  If i < 2 Then GoTo Thoat
  arr = wb.Sheets("Sheet1").Range("A2:C" & i).Value
  wb.Close False: Set wb = Nothing
 
  Call AddDic(dic, arr)
  With ThisWorkbook.Sheets("sheet1")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    jCol = .Range("AAA3").End(xlToLeft).Column
    If i < 3 Or jCol < 3 Then GoTo Thoat
    arr = .Range("A3", .Cells(i, jCol)).Value
    sCol = Int(UBound(arr, 2) / 3) * 3
  End With
  sRow = UBound(arr)
  ReDim res(1 To sRow, 1 To sCol)
  For i = 1 To sRow
    key = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)
    If dic.exists(key) Then a = dic(key) Else a = Array(, 1, 2, 3)
    For k = 1 To sCol Step 3
      For j = 1 To 3
        res(i, k + j - 1) = arr(i, k + a(j) - 1)
      Next j
    Next k
  Next i
  ThisWorkbook.Sheets("sheet1").Range("A3").Resize(sRow, sCol) = res

  If sRow = -1 Then
Thoat:
    MsgBox ("Khong co du lieu!")
  End If
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

Private Sub AddDic(dic, arr)
  Dim a, sR&, i&, j&, key$
  Set dic = CreateObject("scripting.dictionary")
  a = Array(1, 2, 3, 1, 3, 2, 2, 1, 3, 2, 3, 1, 3, 1, 2, 3, 2, 1) 'Hoan Vi
  sR = UBound(arr)
  For i = 1 To sR
    For j = 0 To 17 Step 3
      key = arr(i, a(j)) & "|" & arr(i, a(j + 1)) & "|" & arr(i, a(j + 2))
      If dic.exists(key) = False Then dic(key) = Array(, a(j), a(j + 1), a(j + 2))
    Next j
  Next i
End Sub
Nhấp chuột vào đây để mở rộng...
Em xin cảm ơn ạ
 
Upvote 0
HieuCD đã viết:
Copy code vào module của file B, chạy sub XYZ
Mã: 
Option Explicit
Sub XYZ()
  Dim wb As Workbook, dic As Object, arr(), res(), a
  Dim sRow&, sCol&, i&, j&, jCol&, k&, key$
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  On Error GoTo Thoat
  Set wb = Workbooks.Open(ThisWorkbook.Path & "\FILE A.xlsx")
  i = wb.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
  If i < 2 Then GoTo Thoat
  arr = wb.Sheets("Sheet1").Range("A2:C" & i).Value
  wb.Close False: Set wb = Nothing
 
  Call AddDic(dic, arr)
  With ThisWorkbook.Sheets("sheet1")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    jCol = .Range("AAA3").End(xlToLeft).Column
    If i < 3 Or jCol < 3 Then GoTo Thoat
    arr = .Range("A3", .Cells(i, jCol)).Value
    sCol = Int(UBound(arr, 2) / 3) * 3
  End With
  sRow = UBound(arr)
  ReDim res(1 To sRow, 1 To sCol)
  For i = 1 To sRow
    key = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)
    If dic.exists(key) Then a = dic(key) Else a = Array(, 1, 2, 3)
    For k = 1 To sCol Step 3
      For j = 1 To 3
        res(i, k + j - 1) = arr(i, k + a(j) - 1)
      Next j
    Next k
  Next i
  ThisWorkbook.Sheets("sheet1").Range("A3").Resize(sRow, sCol) = res

  If sRow = -1 Then
Thoat:
    MsgBox ("Khong co du lieu!")
  End If
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

Private Sub AddDic(dic, arr)
  Dim a, sR&, i&, j&, key$
  Set dic = CreateObject("scripting.dictionary")
  a = Array(1, 2, 3, 1, 3, 2, 2, 1, 3, 2, 3, 1, 3, 1, 2, 3, 2, 1) 'Hoan Vi
  sR = UBound(arr)
  For i = 1 To sR
    For j = 0 To 17 Step 3
      key = arr(i, a(j)) & "|" & arr(i, a(j + 1)) & "|" & arr(i, a(j + 2))
      If dic.exists(key) = False Then dic(key) = Array(, a(j), a(j + 1), a(j + 2))
    Next j
  Next i
End Sub
Nhấp chuột vào đây để mở rộng...
Em cảm ơn ạ, bác có thể cho em một chức năng nữa là bôi màu các hàng đã thay đổi được không ạ, vì một trang dữ liệu dài như vậy ko biết cái hàng nào đã thay đổi cũng khó quản lý, em xin lỗi vì đã không nói vấn đề này từ đầu.
 
Upvote 0
tunglinhmot đã viết:
Em cảm ơn ạ, bác có thể cho em một chức năng nữa là bôi màu các hàng đã thay đổi được không ạ, vì một trang dữ liệu dài như vậy ko biết cái hàng nào đã thay đổi cũng khó quản lý, em xin lỗi vì đã không nói vấn đề này từ đầu.
Nhấp chuột vào đây để mở rộng...
Code khá rối nhằm tăng tốc xử lý khi dữ liệu nhiều
Mã: 
Option Explicit
Sub XYZ()
  Dim wb As Workbook, rng As Range, dic As Object, arr(), res(), a
  Dim sRow&, sCol&, i&, j&, jCol&, k&, N&, key$
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  On Error GoTo Thoat
  Set wb = Workbooks.Open(ThisWorkbook.Path & "\FILE A.xlsx")
  i = wb.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
  If i < 2 Then GoTo Thoat
  arr = wb.Sheets("Sheet1").Range("A2:C" & i).Value
  wb.Close False: Set wb = Nothing
 
  Call AddDic(dic, arr)
  With ThisWorkbook.Sheets("sheet1")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    jCol = .Range("AAA3").End(xlToLeft).Column
    If i < 3 Or jCol < 3 Then GoTo Thoat
    arr = .Range("A3", .Cells(i, jCol)).Value
    sCol = Int(UBound(arr, 2) / 3) * 3
  End With
  sRow = UBound(arr)
  ReDim res(1 To sRow, 1 To sCol + 1)
  For i = 1 To sRow
    key = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)
    If dic.exists(key) Then a = dic(key) Else a = Array(, 1, 2, 3)
    For k = 1 To sCol Step 3
      For j = 1 To 3
        res(i, k + j - 1) = arr(i, k + a(j) - 1)
      Next j
    Next k
    res(i, sCol + 1) = a(4)
  Next i
  With ThisWorkbook.Sheets("sheet1")
    .Range("A3").Resize(sRow, sCol) = res
    .Range("A3").Resize(sRow, 3).Interior.Pattern = xlNone
    For i = 1 To sRow
      If res(i, sCol + 1) = 1 Then
        If N = 0 Then
          Set rng = .Range("A" & i + 2).Resize(, 3)
          N = 1
        Else
          If N = 50 Then
            rng.Interior.ColorIndex = 40
            N = 0
          Else
            N = N + 1
            Set rng = Union(rng, .Range("A" & i + 2).Resize(, 3))
          End If
        End If
      End If
    Next i
    If N > 0 And N < 50 Then rng.Interior.ColorIndex = 40
  End With

  If sRow = -1 Then
Thoat:
    MsgBox ("Khong co du lieu!")
  End If
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

Private Sub AddDic(dic, arr)
  Dim a, sR&, i&, j&, key$
  Set dic = CreateObject("scripting.dictionary")
  a = Array(1, 2, 3, 1, 3, 2, 2, 1, 3, 2, 3, 1, 3, 1, 2, 3, 2, 1) 'Hoan Vi
  sR = UBound(arr)
  For i = 1 To sR
    key = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)
    If dic.exists(key) = False Then dic(key) = Array(, 1, 2, 3, 0)
    For j = 3 To 17 Step 3
      key = arr(i, a(j)) & "|" & arr(i, a(j + 1)) & "|" & arr(i, a(j + 2))
      If dic.exists(key) = False Then dic(key) = Array(, a(j), a(j + 1), a(j + 2), 1)
    Next j
  Next i
End Sub
 
Upvote 0
HieuCD đã viết:
Code khá rối nhằm tăng tốc xử lý khi dữ liệu nhiều
Mã: 
Option Explicit
Sub XYZ()
  Dim wb As Workbook, rng As Range, dic As Object, arr(), res(), a
  Dim sRow&, sCol&, i&, j&, jCol&, k&, N&, key$
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  On Error GoTo Thoat
  Set wb = Workbooks.Open(ThisWorkbook.Path & "\FILE A.xlsx")
  i = wb.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
  If i < 2 Then GoTo Thoat
  arr = wb.Sheets("Sheet1").Range("A2:C" & i).Value
  wb.Close False: Set wb = Nothing
 
  Call AddDic(dic, arr)
  With ThisWorkbook.Sheets("sheet1")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    jCol = .Range("AAA3").End(xlToLeft).Column
    If i < 3 Or jCol < 3 Then GoTo Thoat
    arr = .Range("A3", .Cells(i, jCol)).Value
    sCol = Int(UBound(arr, 2) / 3) * 3
  End With
  sRow = UBound(arr)
  ReDim res(1 To sRow, 1 To sCol + 1)
  For i = 1 To sRow
    key = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)
    If dic.exists(key) Then a = dic(key) Else a = Array(, 1, 2, 3)
    For k = 1 To sCol Step 3
      For j = 1 To 3
        res(i, k + j - 1) = arr(i, k + a(j) - 1)
      Next j
    Next k
    res(i, sCol + 1) = a(4)
  Next i
  With ThisWorkbook.Sheets("sheet1")
    .Range("A3").Resize(sRow, sCol) = res
    .Range("A3").Resize(sRow, 3).Interior.Pattern = xlNone
    For i = 1 To sRow
      If res(i, sCol + 1) = 1 Then
        If N = 0 Then
          Set rng = .Range("A" & i + 2).Resize(, 3)
          N = 1
        Else
          If N = 50 Then
            rng.Interior.ColorIndex = 40
            N = 0
          Else
            N = N + 1
            Set rng = Union(rng, .Range("A" & i + 2).Resize(, 3))
          End If
        End If
      End If
    Next i
    If N > 0 And N < 50 Then rng.Interior.ColorIndex = 40
  End With

  If sRow = -1 Then
Thoat:
    MsgBox ("Khong co du lieu!")
  End If
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

Private Sub AddDic(dic, arr)
  Dim a, sR&, i&, j&, key$
  Set dic = CreateObject("scripting.dictionary")
  a = Array(1, 2, 3, 1, 3, 2, 2, 1, 3, 2, 3, 1, 3, 1, 2, 3, 2, 1) 'Hoan Vi
  sR = UBound(arr)
  For i = 1 To sR
    key = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)
    If dic.exists(key) = False Then dic(key) = Array(, 1, 2, 3, 0)
    For j = 3 To 17 Step 3
      key = arr(i, a(j)) & "|" & arr(i, a(j + 1)) & "|" & arr(i, a(j + 2))
      If dic.exists(key) = False Then dic(key) = Array(, a(j), a(j + 1), a(j + 2), 1)
    Next j
  Next i
End Sub
Nhấp chuột vào đây để mở rộng...
Bác ơi, phần code của bác em thử với dữ liệu mỗi ô cell kiểu 1 ký tự thì được nhưng khi thay dữ liệu mỗi ô cell thành 11 kí tự thì nó chạy luôn đến phần MsgBox ("Khong co du lieu!"). Bác xem lỗi này giúp em với. Em cảm ở nhiều ạ.
 
Upvote 0
tunglinhmot đã viết:
Bác ơi, phần code của bác em thử với dữ liệu mỗi ô cell kiểu 1 ký tự thì được nhưng khi thay dữ liệu mỗi ô cell thành 11 kí tự thì nó chạy luôn đến phần MsgBox ("Khong co du lieu!"). Bác xem lỗi này giúp em với. Em cảm ở nhiều ạ.
Nhấp chuột vào đây để mở rộng...
11 ký tự code chạy phà phà, chỉ khi thứ tự dòng, thứ tự cột hoặc tên sheet thay đổi code sẽ chạy lung tung. Gởi 2 file xem bị gì
 
Upvote 0
HieuCD đã viết:
11 ký tự code chạy phà phà, chỉ khi thứ tự dòng, thứ tự cột hoặc tên sheet thay đổi code sẽ chạy lung tung. Gởi 2 file xem bị gì
Nhấp chuột vào đây để mở rộng...
Em thử lại rồi, lại thấy code chạy được, nhưng nhiều lúc nó không làm gì mà chạy thẳng đến phần MsgBox ("Khong co du lieu!") luôn, em cũng không biết lý do tại sao dù thứ tự dòng, thứ tự cột hoặc tên sheet không thay đổi gì. Mà lúc nó chạy được thì luôn có mấy hàng như hàng 53, 104, 155, 206... tuy giá trị đã được đổi nhưng nó không bôi màu các hàng đó anh ạ. Anh xem lại giúp em với ạ. Em cảm ơn nhiều.
2 file A,B em đính kèm ở dưới đó ạ.
 

File đính kèm

  • FILE A.xlsx
    18 KB · Đọc: 5
  • FILE B.xlsm
    52.1 KB · Đọc: 5
Upvote 0
tunglinhmot đã viết:
Em thử lại rồi, lại thấy code chạy được, nhưng nhiều lúc nó không làm gì mà chạy thẳng đến phần MsgBox ("Khong co du lieu!") luôn, em cũng không biết lý do tại sao dù thứ tự dòng, thứ tự cột hoặc tên sheet không thay đổi gì. Mà lúc nó chạy được thì luôn có mấy hàng như hàng 53, 104, 155, 206... tuy giá trị đã được đổi nhưng nó không bôi màu các hàng đó anh ạ. Anh xem lại giúp em với ạ. Em cảm ơn nhiều.
2 file A,B em đính kèm ở dưới đó ạ.
Nhấp chuột vào đây để mở rộng...
Code chạy bình thường, bạn bỏ dòng lệnh "On Error GoTo Thoat" xem nó báo lỗi gì và tự chỉnh theo thông báo lỗi
File mới có các hàng 53, 104, 155, 206 không đổi nên không tô màu
 
Upvote 0
HieuCD đã viết:
Code chạy bình thường, bạn bỏ dòng lệnh "On Error GoTo Thoat" xem nó báo lỗi gì và tự chỉnh theo thông báo lỗi
File mới có các hàng 53, 104, 155, 206 không đổi nên không tô màu
Nhấp chuột vào đây để mở rộng...
Em bỏ dòng "On Error GoTo Thoat" , rồi phát hiện lỗi là do có các hàng mà dữ liệu các ô cell trong đó không có trong dictionary (tức là File A) nên code bị lỗi từ dòng này: res(i, sCol + 1) = a(4)
Phần này anh có thế sửa lại giúp em là với các hàng trong file B mà có dữ liệu ô cell, hoặc các tổ hợp ở 3 cột A,B,C không có trong File A thì mình sẽ bôi màu thêm hàng đó rồi chạy tiếp sang hàng khác được không ạ.
Em gưi file đính kèm ở dưới ạ. Em xin cảm ơn.
 

File đính kèm

  • FILE A.xlsx
    9.3 KB · Đọc: 9
  • FILE B.xlsm
    45.4 KB · Đọc: 7
Lần chỉnh sửa cuối:
Upvote 0
tunglinhmot đã viết:
Em bỏ dòng "On Error GoTo Thoat" , rồi phát hiện lỗi là do có các hàng mà dữ liệu các ô cell trong đó không có trong dictionary (tức là File A) nên code bị lỗi từ dòng này: res(i, sCol + 1) = a(4)
Phần này anh có thế sửa lại giúp em là với các hàng trong file B mà có dữ liệu ô cell, hoặc các tổ hợp ở 3 cột A,B,C không có trong File A thì mình sẽ bôi màu thêm hàng đó rồi chạy tiếp sang hàng khác được không ạ.
Em gưi file đính kèm ở dưới ạ. Em xin cảm ơn.
Nhấp chuột vào đây để mở rộng...
Chỉnh dòng lệnh
If dic.exists(key) Then a = dic(key) Else a = Array(, 1, 2, 3, 1)
Mã: 
Sub XYZ()
  Dim wb As Workbook, rng As Range, dic As Object, arr(), res(), a
  Dim sRow&, sCol&, i&, j&, jCol&, k&, N&, key$
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
'  On Error GoTo Thoat
  Set wb = Workbooks.Open(ThisWorkbook.Path & "\FILE A.xlsx")
  i = wb.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
  If i < 2 Then GoTo Thoat
  arr = wb.Sheets("Sheet1").Range("A2:C" & i).Value
  wb.Close False: Set wb = Nothing
 
  Call AddDic(dic, arr)
  With ThisWorkbook.Sheets("sheet1")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    jCol = .Range("AAA3").End(xlToLeft).Column
    If i < 3 Or jCol < 3 Then GoTo Thoat
    arr = .Range("A3", .Cells(i, jCol)).Value
    sCol = Int(UBound(arr, 2) / 3) * 3
  End With
  sRow = UBound(arr)
  ReDim res(1 To sRow, 1 To sCol + 1)
  For i = 1 To sRow
    key = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)
    If dic.exists(key) Then a = dic(key) Else a = Array(, 1, 2, 3, 1)
    For k = 1 To sCol Step 3
      For j = 1 To 3
        res(i, k + j - 1) = arr(i, k + a(j) - 1)
      Next j
    Next k
    res(i, sCol + 1) = a(4)
  Next i
  With ThisWorkbook.Sheets("sheet1")
    .Range("A3").Resize(sRow, sCol) = res
    .Range("A3").Resize(sRow, 3).Interior.Pattern = xlNone
    For i = 1 To sRow
      If res(i, sCol + 1) = 1 Then
        If N = 0 Then
          Set rng = .Range("A" & i + 2).Resize(, 3)
          N = 1
        Else
          If N = 50 Then
            rng.Interior.ColorIndex = 40
            N = 0
          Else
            N = N + 1
            Set rng = Union(rng, .Range("A" & i + 2).Resize(, 3))
          End If
        End If
      End If
    Next i
    If N > 0 And N < 50 Then rng.Interior.ColorIndex = 40
  End With

  If sRow = -1 Then
Thoat:
    MsgBox ("Khong co du lieu!")
  End If
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub
 
Upvote 0
HieuCD đã viết:
Chỉnh dòng lệnh
If dic.exists(key) Then a = dic(key) Else a = Array(, 1, 2, 3, 1)
Mã: 
Sub XYZ()
  Dim wb As Workbook, rng As Range, dic As Object, arr(), res(), a
  Dim sRow&, sCol&, i&, j&, jCol&, k&, N&, key$
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
'  On Error GoTo Thoat
  Set wb = Workbooks.Open(ThisWorkbook.Path & "\FILE A.xlsx")
  i = wb.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
  If i < 2 Then GoTo Thoat
  arr = wb.Sheets("Sheet1").Range("A2:C" & i).Value
  wb.Close False: Set wb = Nothing
 
  Call AddDic(dic, arr)
  With ThisWorkbook.Sheets("sheet1")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    jCol = .Range("AAA3").End(xlToLeft).Column
    If i < 3 Or jCol < 3 Then GoTo Thoat
    arr = .Range("A3", .Cells(i, jCol)).Value
    sCol = Int(UBound(arr, 2) / 3) * 3
  End With
  sRow = UBound(arr)
  ReDim res(1 To sRow, 1 To sCol + 1)
  For i = 1 To sRow
    key = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)
    If dic.exists(key) Then a = dic(key) Else a = Array(, 1, 2, 3, 1)
    For k = 1 To sCol Step 3
      For j = 1 To 3
        res(i, k + j - 1) = arr(i, k + a(j) - 1)
      Next j
    Next k
    res(i, sCol + 1) = a(4)
  Next i
  With ThisWorkbook.Sheets("sheet1")
    .Range("A3").Resize(sRow, sCol) = res
    .Range("A3").Resize(sRow, 3).Interior.Pattern = xlNone
    For i = 1 To sRow
      If res(i, sCol + 1) = 1 Then
        If N = 0 Then
          Set rng = .Range("A" & i + 2).Resize(, 3)
          N = 1
        Else
          If N = 50 Then
            rng.Interior.ColorIndex = 40
            N = 0
          Else
            N = N + 1
            Set rng = Union(rng, .Range("A" & i + 2).Resize(, 3))
          End If
        End If
      End If
    Next i
    If N > 0 And N < 50 Then rng.Interior.ColorIndex = 40
  End With

  If sRow = -1 Then
Thoat:
    MsgBox ("Khong co du lieu!")
  End If
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub
Nhấp chuột vào đây để mở rộng...
Được rồi ạ , em cảm ơn anh
 
Upvote 0
HieuCD đã viết:
Chỉnh dòng lệnh
If dic.exists(key) Then a = dic(key) Else a = Array(, 1, 2, 3, 1)
Mã: 
Sub XYZ()
  Dim wb As Workbook, rng As Range, dic As Object, arr(), res(), a
  Dim sRow&, sCol&, i&, j&, jCol&, k&, N&, key$
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
'  On Error GoTo Thoat
  Set wb = Workbooks.Open(ThisWorkbook.Path & "\FILE A.xlsx")
  i = wb.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
  If i < 2 Then GoTo Thoat
  arr = wb.Sheets("Sheet1").Range("A2:C" & i).Value
  wb.Close False: Set wb = Nothing
 
  Call AddDic(dic, arr)
  With ThisWorkbook.Sheets("sheet1")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    jCol = .Range("AAA3").End(xlToLeft).Column
    If i < 3 Or jCol < 3 Then GoTo Thoat
    arr = .Range("A3", .Cells(i, jCol)).Value
    sCol = Int(UBound(arr, 2) / 3) * 3
  End With
  sRow = UBound(arr)
  ReDim res(1 To sRow, 1 To sCol + 1)
  For i = 1 To sRow
    key = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)
    If dic.exists(key) Then a = dic(key) Else a = Array(, 1, 2, 3, 1)
    For k = 1 To sCol Step 3
      For j = 1 To 3
        res(i, k + j - 1) = arr(i, k + a(j) - 1)
      Next j
    Next k
    res(i, sCol + 1) = a(4)
  Next i
  With ThisWorkbook.Sheets("sheet1")
    .Range("A3").Resize(sRow, sCol) = res
    .Range("A3").Resize(sRow, 3).Interior.Pattern = xlNone
    For i = 1 To sRow
      If res(i, sCol + 1) = 1 Then
        If N = 0 Then
          Set rng = .Range("A" & i + 2).Resize(, 3)
          N = 1
        Else
          If N = 50 Then
            rng.Interior.ColorIndex = 40
            N = 0
          Else
            N = N + 1
            Set rng = Union(rng, .Range("A" & i + 2).Resize(, 3))
          End If
        End If
      End If
    Next i
    If N > 0 And N < 50 Then rng.Interior.ColorIndex = 40
  End With

  If sRow = -1 Then
Thoat:
    MsgBox ("Khong co du lieu!")
  End If
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub
Nhấp chuột vào đây để mở rộng...
Em xin phép phiền anh thêm một chút ạ. Về cái Private sub AddDic thì dù biến i chạy từ 1 đến dòng cuối (sR), nhưng em nhìn trong cửa sổ local thì tổng số hoán vị trong Dic chỉ chứa được tối đa 256 giá trị nên đối với các file có số hàng tầm 2000 hàng trở lên thì nó không thể add hết các tổ hợp hoán vị vào dic được. Có cách nào mở rộng phạm vi của dic hơn nữa được không ạ.

Private Sub AddDic(dic, arr)
Dim a, sR&, i&, j&, key$
Set dic = CreateObject("scripting.dictionary")
a = Array(1, 2, 3, 1, 3, 2, 2, 1, 3, 2, 3, 1, 3, 1, 2, 3, 2, 1) 'Hoan Vi
sR = UBound(arr)
For i = 1 To sR
key = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)
If dic.exists(key) = False Then dic(key) = Array(, 1, 2, 3, 0)
For j = 3 To 17 Step 3
key = arr(i, a(j)) & "|" & arr(i, a(j + 1)) & "|" & arr(i, a(j + 2))
If dic.exists(key) = False Then dic(key) = Array(, a(j), a(j + 1), a(j + 2), 1)
Next j
Next i
End Sub
 
Lần chỉnh sửa cuối:
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

thlpro
Truy Vấn Công thức từ Sheet này Qua Sheet Khác
Trả lời
0
Đọc
14
thlpro
thlpro
ongke0711
  • Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
7 8 9
Trả lời
179
Đọc
9K
ongke0711
ongke0711
B
Sắp xếp lịch trực
5 6 7
Trả lời
130
Đọc
86K
TTVAN28
TTVAN28
N
Giúp em hàm Aggregate không chạy được trên Google sheet ah
Trả lời
4
Đọc
112
nguyenthieny
N
hunganh.nguyen
Xin giúp code tách dòng tổng thành những dòng chi tiết với giá trị là 1
Trả lời
8
Đọc
376
DeTong
D
S
Chuyển định dạng thời gian từ sa/ch sang AM/PM
Trả lời
1
Đọc
27
bebo021999
B
N
  • Question
VBA - copy các sheets unhide và dạng giá trị theo vùng xác định
Trả lời
2
Đọc
38
bebo021999
B
hoaithanh9480
Nhờ giúp đỡ về kiểm phiếu bầu
Trả lời
4
Đọc
57
hoaithanh9480
hoaithanh9480
B
Nhờ anh/chị giúp em tìm hàm cho công thức tính lương
Trả lời
2
Đọc
97
hoangtuaotrang_hp_vn
H
SA_DQ
Phẩu thuật Nụ cười lần 3 tại Huế.
    • Thích
    • Yêu thích
Trả lời
1
Đọc
73
HUONGHCKT
H
K
  • Question
Sử dụng Power Query để xử lý nhật ký chung nhiều nợ nhiều có
    • Cười
Trả lời
14
Đọc
270
viethung78
V
N
cộng các dữ liệu không trùng nhau
Trả lời
13
Đọc
224
DeTong
D
T
Lỗi import dữ liệu
Trả lời
1
Đọc
30
ongke0711
ongke0711
Huy@@*
Giải đáp giùm em, cách khắc phục lỗi này trên VBA
2
Trả lời
28
Đọc
367
ptm0412
ptm0412
E
  • Question
Tạo bảng lọc theo điều kiện
Trả lời
7
Đọc
142
Hoàng Tuấn 868
H
Bùi Thúy Thúy
  • Question
Lấy dữ liệu thời tiết Accuweather để điền vào nhật ký thi công
2 3 4
Trả lời
62
Đọc
18K
HeSanbi
HeSanbi
vova2209
Index kết hợp với match 2 điều kiện
Trả lời
14
Đọc
1K
dunghtgiga
dunghtgiga
D
  • Question
Xin cách tạo tab và button cho Add-in trên ribbon Maintabs
Trả lời
2
Đọc
104
Decepticon
D
T
Chèn dữ liệu từ sheet này qua sheet khác theo điều kiện
Trả lời
3
Đọc
146
HieuCD
H
T
Trùng 2 lần: Tìm dữ liệu nhiều điều kiện
Trả lời
0
Đọc
89
Thulib
T
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

Back
Top Bottom