[Help] VBA Replace theo điều kiện Tên cột đã khai báo sẵn

[ngoctuyen1995]

Thân chào cả nhà GPEX!
Mong cả nhà giúp em một việc bên dưới ạ:
Hiện tại em có 01 File data gồm Sheet Data và Sheet Điều kiện, Từ sheet Điều kiện em có một list danh sách gồm 03 cột (Name Columns, Dieu kien, replace)---> Đây là danh sách khai báo điều kiện

Ví dụ: tên cột Q9_Ten Xuong , bên data hiện tại đang hiển thị các code 1,2,3,4, em muốn replace dựa vào sheet điều kiện tìm đến cột có tên Q9_Ten Xuong (trong sheet Data) và replace theo các điều kiện đã khai báo sẵn bên sheet Điều kiện.
1 --> Cty Son A
2 --> Cty Son B
3 --> Cty Son C
4 --> Cty Son D
Tương tự sẽ tiếp tục cho những cột khai báo còn lại

Mong cả nhà giúp đỡ... Em xin cảm ơn ạ..!

 

[snow25]

Thân chào cả nhà GPEX!
Mong cả nhà giúp em một việc bên dưới ạ:
Hiện tại em có 01 File data gồm Sheet Data và Sheet Điều kiện, Từ sheet Điều kiện em có một list danh sách gồm 03 cột (Name Columns, Dieu kien, replace)---> Đây là danh sách khai báo điều kiện

Ví dụ: tên cột Q9_Ten Xuong , bên data hiện tại đang hiển thị các code 1,2,3,4, em muốn replace dựa vào sheet điều kiện tìm đến cột có tên Q9_Ten Xuong (trong sheet Data) và replace theo các điều kiện đã khai báo sẵn bên sheet Điều kiện.
1 --> Cty Son A
2 --> Cty Son B
3 --> Cty Son C
4 --> Cty Son D
Tương tự sẽ tiếp tục cho những cột khai báo còn lại

Mong cả nhà giúp đỡ... Em xin cảm ơn ạ..!

Bạn chạy code này xem nhé.

Sub thaythe()
Dim arr, arr1
Dim lr As Long, a As Long, i As Long, dk As String, j As Long
Dim dic As Object
Set dic = CreateObject("scripting.dictionary")
With Sheets("dieukien")
     lr = .Range("B" & Rows.Count).End(xlUp).Row
     If lr < 2 Then Exit Sub
     arr = .Range("A2:C" & lr).Value
     For i = 1 To UBound(arr, 1)
         If arr(i, 1) = Empty Then arr(i, 1) = arr(i - 1, 1)
         dk = arr(i, 1) & "#" & arr(i, 2)
         If Not dic.exists(dk) Then
           dic.Add dk, arr(i, 3)
         End If
     Next i
End With
With Sheets("data")
    lr = .Range("A" & Rows.Count).End(xlUp).Row
    arr = .Range("A1:X" & lr).Value
    If lr < 2 Then Exit Sub
    For j = 1 To UBound(arr, 2)
       For i = 2 To UBound(arr, 1)
           dk = arr(1, j) & "#" & arr(i, j)
           If dic.exists(dk) Then
                 arr(i, j) = dic.Item(dk)
           End If
       Next i
    Next j
    .Range("A1:X" & lr).Value = arr
End With
End Sub

 

[ngoctuyen1995]

Bạn chạy code này xem nhé.

Sub thaythe()
Dim arr, arr1
Dim lr As Long, a As Long, i As Long, dk As String, j As Long
Dim dic As Object
Set dic = CreateObject("scripting.dictionary")
With Sheets("dieukien")
     lr = .Range("B" & Rows.Count).End(xlUp).Row
     If lr < 2 Then Exit Sub
     arr = .Range("A2:C" & lr).Value
     For i = 1 To UBound(arr, 1)
         If arr(i, 1) = Empty Then arr(i, 1) = arr(i - 1, 1)
         dk = arr(i, 1) & "#" & arr(i, 2)
         If Not dic.exists(dk) Then
           dic.Add dk, arr(i, 3)
         End If
     Next i
End With
With Sheets("data")
    lr = .Range("A" & Rows.Count).End(xlUp).Row
    arr = .Range("A1:X" & lr).Value
    If lr < 2 Then Exit Sub
    For j = 1 To UBound(arr, 2)
       For i = 2 To UBound(arr, 1)
           dk = arr(1, j) & "#" & arr(i, j)
           If dic.exists(dk) Then
                 arr(i, j) = dic.Item(dk)
           End If
       Next i
    Next j
    .Range("A1:X" & lr).Value = arr
End With
End Sub

Em cảm ơn vì đã giúp đỡ em ạ, code chạy tốt và rất đúng ý em..

Chúc Anh sức khỏe và thành công ạ