Tìm kiếm và thay thế các giá trị trong cột F,H và L (1 người xem)

[phulien1902]

Xin chào mọi người.
Hiện tại tôi có 1 File cần chuyển đổi các giá trị trong 3 cột F, H và L( Sheet1) sang 1 dạng khác thông qua bảng tra màu xanh nhat, có kết quả như Sheets("kq").
Tôi đã làm 1 bước trung gian qua Sheet2, mọi người xem sẽ hiểu được ngay.
Ai đó có thể giúp tôi giải quyết khó khăn này.
Xin cảm ơn.

 

[giangleloi]

Xin chào mọi người.
Hiện tại tôi có 1 File cần chuyển đổi các giá trị trong 3 cột F, H và L( Sheet1) sang 1 dạng khác thông qua bảng tra màu xanh nhat, có kết quả như Sheets("kq").
Tôi đã làm 1 bước trung gian qua Sheet2, mọi người xem sẽ hiểu được ngay.
Ai đó có thể giúp tôi giải quyết khó khăn này.
Xin cảm ơn.

Bạn kiểm tra thử xem nha. Đang viết có "kèo" hối đi "nhậu" rồi nên chưa làm gọn code với test trước khi gửi được. Bởi vậy nó như mớ hỗn độn. Xài tạm thử.

Sub GPE()
Dim Arr(), vlArr(), DK(), I As Long, J As Long, K As Long
With Sheet1
 DK = .[Q2:S18].Value
 Arr = .Range(.[A3], .[A65000].End(3)).Resize(, 14).Value
End With
 ReDim vlArr(1 To UBound(Arr, 1), 1 To 14)
 For I = 1 To UBound(Arr, 1)
   K = K + 1
   For J = 1 To 5
    vlArr(K, J) = Arr(I, J)
   Next J
    For J = 1 To UBound(DK, 1)
      If Arr(I, 6) < DK(J, 1) Then
         vlArr(K, 6) = DK(J - 1, 3): Exit For
      End If
      If vlArr(K, 6) = Empty Then vlArr(K, 6) = DK(J, 3)
    Next J
     vlArr(K, 7) = Arr(I, 7)
    For J = 1 To UBound(DK, 1)
      If Arr(I, 8) < DK(J, 1) Then
         vlArr(K, 8) = DK(J - 1, 3): Exit For
      End If
      If vlArr(K, 8) = Empty Then vlArr(K, 8) = DK(J, 3)
    Next J
    For J = 9 To 11
     vlArr(K, J) = Arr(I, J)
    Next J
    For J = 1 To UBound(DK, 1)
      If Arr(I, 12) < DK(J, 1) Then
         vlArr(K, 12) = DK(J - 1, 3): Exit For
      End If
      If vlArr(K, 12) = Empty Then vlArr(K, 12) = DK(J, 3)
    Next J
     vlArr(K, 13) = Arr(I, 13)
     vlArr(K, 14) = Arr(I, 14)
 Next I
With Sheet3
 .[A3:N10000].ClearContents
 .[A3].Resize(K, 14) = vlArr
End With
End Sub

 

[phulien1902]

Bạn kiểm tra thử xem nha. Đang viết có "kèo" hối đi "nhậu" rồi nên chưa làm gọn code với test trước khi gửi được. Bởi vậy nó như mớ hỗn độn. Xài tạm thử.

Sub GPE()
Dim Arr(), vlArr(), DK(), I As Long, J As Long, K As Long
With Sheet1
 DK = .[Q2:S18].Value
 Arr = .Range(.[A3], .[A65000].End(3)).Resize(, 14).Value
End With
 ReDim vlArr(1 To UBound(Arr, 1), 1 To 14)
 For I = 1 To UBound(Arr, 1)
   K = K + 1
   For J = 1 To 5
    vlArr(K, J) = Arr(I, J)
   Next J
    For J = 1 To UBound(DK, 1)
      If Arr(I, 6) < DK(J, 1) Then
         vlArr(K, 6) = DK(J - 1, 3): Exit For
      End If
      If vlArr(K, 6) = Empty Then vlArr(K, 6) = DK(J, 3)
    Next J
     vlArr(K, 7) = Arr(I, 7)
    For J = 1 To UBound(DK, 1)
      If Arr(I, 8) < DK(J, 1) Then
         vlArr(K, 8) = DK(J - 1, 3): Exit For
      End If
      If vlArr(K, 8) = Empty Then vlArr(K, 8) = DK(J, 3)
    Next J
    For J = 9 To 11
     vlArr(K, J) = Arr(I, J)
    Next J
    For J = 1 To UBound(DK, 1)
      If Arr(I, 12) < DK(J, 1) Then
         vlArr(K, 12) = DK(J - 1, 3): Exit For
      End If
      If vlArr(K, 12) = Empty Then vlArr(K, 12) = DK(J, 3)
    Next J
     vlArr(K, 13) = Arr(I, 13)
     vlArr(K, 14) = Arr(I, 14)
 Next I
With Sheet3
 .[A3:N10000].ClearContents
 .[A3].Resize(K, 14) = vlArr
End With
End Sub

Cảm ơn bạn giangleloi nhiều.

 

[HungQuoc49]

Xin chào mọi người.
Hiện tại tôi có 1 File cần chuyển đổi các giá trị trong 3 cột F, H và L( Sheet1) sang 1 dạng khác thông qua bảng tra màu xanh nhat, có kết quả như Sheets("kq").
Tôi đã làm 1 bước trung gian qua Sheet2, mọi người xem sẽ hiểu được ngay.
Ai đó có thể giúp tôi giải quyết khó khăn này.
Xin cảm ơn.

Thử code này xem sao

Public Sub ThayThe()
Dim DK, CotF, CotH, CotL
Dim r, c

DK = Sheet1.Range("Q2", "S18")
CotF = Sheet1.Range("F3", Sheet1.Range("F3").End(xlDown))
CotH = Sheet1.Range("H3", Sheet1.Range("H3").End(xlDown))
CotL = Sheet1.Range("L3", Sheet1.Range("L3").End(xlDown))

With CreateObject("Scripting.dictionary")
For r = 1 To UBound(DK)
For c = DK(r, 1) To DK(r, 2)
.Add c, DK(r, 3)
Next c
Next r

For r = 1 To UBound(CotF)
If .exists(CotF(r, 1)) Then CotF(r, 1) = .Item(CotF(r, 1))
If .exists(CotH(r, 1)) Then CotH(r, 1) = .Item(CotH(r, 1))
If .exists(CotL(r, 1)) Then CotL(r, 1) = .Item(CotL(r, 1))
Next r
End With

Sheet1.Range("F3").Resize(UBound(CotF), 1).ClearContents
Sheet1.Range("H3").Resize(UBound(CotH), 1).ClearContents
Sheet1.Range("L3").Resize(UBound(CotL), 1).ClearContents

Sheet1.Range("F3").Resize(UBound(CotF), 1) = CotF
Sheet1.Range("H3").Resize(UBound(CotH), 1) = CotH
Sheet1.Range("L3").Resize(UBound(CotL), 1) = CotL
End Sub

 

[Ba Tê]

Xin chào mọi người.
Hiện tại tôi có 1 File cần chuyển đổi các giá trị trong 3 cột F, H và L( Sheet1) sang 1 dạng khác thông qua bảng tra màu xanh nhat, có kết quả như Sheets("kq").
Tôi đã làm 1 bước trung gian qua Sheet2, mọi người xem sẽ hiểu được ngay.
Ai đó có thể giúp tôi giải quyết khó khăn này.
Xin cảm ơn.

Chạy thử Sub này xem sao nhé.

Public Sub GPE()
Dim sArr(), tArr(), I As Long, N As Long
With Sheet1
    sArr = .Range("A3", .Range("A3").End(xlDown)).Resize(, 14).Value
    tArr = .Range("Q2", .Range("Q2").End(xlDown)).Resize(, 3).Value
End With
For I = 1 To UBound(sArr)
    For N = UBound(tArr) To 1 Step -1
        If sArr(I, 6) >= tArr(N, 1) Then
            sArr(I, 6) = tArr(N, 3)
            Exit For
        End If
    Next N
    For N = UBound(tArr) To 1 Step -1
        If sArr(I, 8) >= tArr(N, 1) Then
            sArr(I, 8) = tArr(N, 3)
            Exit For
        End If
    Next N
    For N = UBound(tArr) To 1 Step -1
        If sArr(I, 12) >= tArr(N, 1) Then
            sArr(I, 12) = tArr(N, 3)
            Exit For
        End If
    Next N
Next I
Sheets("kq").Range("A3").Resize(I - 1, 14) = sArr
End Sub

Nếu muôn xài Dic thì chạy cái này:

Public Sub GPE_2()
Dim Dic As Object, sArr(), I As Long, J As Long
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet1
    sArr = .Range("Q2:S18").Value
    For I = 1 To UBound(sArr)
        For J = sArr(I, 1) To sArr(I, 2)
            Dic.Item(J) = sArr(I, 3)
        Next J
    Next I
    sArr = .Range("A3", .Range("A3").End(xlDown)).Resize(, 14).Value
    For I = 1 To UBound(sArr)
        If Dic.Exists(sArr(I, 6)) Then sArr(I, 6) = Dic.Item(sArr(I, 6))
        If Dic.Exists(sArr(I, 8)) Then sArr(I, 8) = Dic.Item(sArr(I, 8))
        If Dic.Exists(sArr(I, 12)) Then sArr(I, 12) = Dic.Item(sArr(I, 12))
    Next I
End With
Sheets("kq").Range("A3").Resize(I - 1, 14) = sArr
Set Dic = Nothing
End Sub

 

[ndu96081631]

Xin chào mọi người.
Hiện tại tôi có 1 File cần chuyển đổi các giá trị trong 3 cột F, H và L( Sheet1) sang 1 dạng khác thông qua bảng tra màu xanh nhat, có kết quả như Sheets("kq").
Tôi đã làm 1 bước trung gian qua Sheet2, mọi người xem sẽ hiểu được ngay.
Ai đó có thể giúp tôi giải quyết khó khăn này.
Xin cảm ơn.

Bài này dùng công thức cũng khá đơn giản. Ví dụ:

=LOOKUP(F3,$Q$2:$S$18)

Vậy thôi rồi kéo fill xuống, xong copy kết quả rồi paste value trở lại. Thiết nghĩ thao tác cũng không mất thời gian bao nhiêu
Còn muốn code cũng có thể dựa vào cách trên:

Sub Test()
  With WorksheetFunction
    Range("F3:F945").Value = .Lookup(Range("F3:F945"), Range("Q2:S18"))
    Range("H3:H945").Value = .Lookup(Range("H3:H945"), Range("Q2:S18"))
    Range("L3:L945").Value = .Lookup(Range("L3:L945"), Range("Q2:S18"))
  End With
End Sub

Với dữ liệu <10,000 dòng thì tốc độ chắc không có vấn đề

 

[phulien1902]

Xin cảm ơn tất cả các bác và các bạn đã nhiệt tình giúp đỡ. Mỗi người có cách giải quyết vấn đề rất hay.