Nhờ sửa code phương thức find trong vba (1 người xem)

[le thi thuy 3013]

Nhờ các cao thủ sửa giúp em với. Please Please!!! Em muốn tìm kiếm trong cột A của sheet 1 các mã hàng trong sheet 2 rồi đưa các mã này sang cột B. Em chạy thử thì chạy được vài dòng rồi báo lỗi "Application-defined or object defined error"
Sub Macro1()
'

' Keyboard Shortcut: Ctrl+w
'
Dim wb As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set wb = Application.ActiveWorkbook
Set ws1 = wb.Sheets(1)
Set ws2 = wb.Sheets(2)
Dim i As String
Dim Rng, LastCell As Range
Dim FirstAddress As String
For k = 2 To 10
i = ws2.Cells(k, 1).Value
Set LastCell = ws1.Cells(Selection.Cells.Count)

Set Rng = ws1.Cells.Find(What:=i, After:=LastCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)

If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Rng.Offset(0, 1).Value = i
Do
ws1.Columns("A:A").Select


Set Rng = Selection.FindNext(Rng)

Rng.Offset(0, 1).Value = i

Loop While FirstAddress <> Rng.Address
End If
Next k
End Sub

 

[snow25]

Nhờ các cao thủ sửa giúp em với. Please Please!!! Em muốn tìm kiếm trong cột A của sheet 1 các mã hàng trong sheet 2 rồi đưa các mã này sang cột B. Em chạy thử thì chạy được vài dòng rồi báo lỗi "Application-defined or object defined error"
Sub Macro1()
'

' Keyboard Shortcut: Ctrl+w
'
Dim wb As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set wb = Application.ActiveWorkbook
Set ws1 = wb.Sheets(1)
Set ws2 = wb.Sheets(2)
Dim i As String
Dim Rng, LastCell As Range
Dim FirstAddress As String
For k = 2 To 10
i = ws2.Cells(k, 1).Value
Set LastCell = ws1.Cells(Selection.Cells.Count)

Set Rng = ws1.Cells.Find(What:=i, After:=LastCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)

If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Rng.Offset(0, 1).Value = i
Do
ws1.Columns("A:A").Select


Set Rng = Selection.FindNext(Rng)

Rng.Offset(0, 1).Value = i

Loop While FirstAddress <> Rng.Address
End If
Next k
End Sub

Vậy sao bạn không tách luôn từ cột A các mã hàng ra mà lại phải làm lòng vòng vậy.

 

[le thi thuy 3013]

Vậy sao bạn không tách luôn từ cột A các mã hàng ra mà lại phải làm lòng vòng vậy.

mình mới tập tẹ viết code thôi, bạn giúp mình với

 

[snow25]

mình mới tập tẹ viết code thôi, bạn giúp mình với

Đây bạn xem được không.

Sub tach()
Dim arr, tach
Dim i As Long, a As Long
With Sheet1
    arr = .Range("a2:b" & .Range("a" & Rows.Count).End(xlUp).Row).Value
    For i = 1 To UBound(arr, 1)
        tach = Split(arr(i, 1), " ")
        a = UBound(tach)
        arr(i, 2) = tach(a)
    Next i
    .Range("a2").Resize(i - 1, 2).Value = arr
End With
End Sub

 

[le thi thuy 3013]

Đây bạn xem được không.

Sub tach()
Dim arr, tach
Dim i As Long, a As Long
With Sheet1
    arr = .Range("a2:b" & .Range("a" & Rows.Count).End(xlUp).Row).Value
    For i = 1 To UBound(arr, 1)
        tach = Split(arr(i, 1), " ")
        a = UBound(tach)
        arr(i, 2) = tach(a)
    Next i
    .Range("a2").Resize(i - 1, 2).Value = arr
End With
End Sub

Đội ơn bạn,hi hi mình chạy được rồi bạn ạ, nhưng có 1 nhược điểm đó là bạn chọn tách ký tự cuối cùng, nếu mã hàng không nằm ở cuối vd như quạt điện J137M hàng mới 100% thì sao?

 

[snow25]

Đội ơn bạn,hi hi mình chạy được rồi bạn ạ, nhưng có 1 nhược điểm đó là bạn chọn tách ký tự cuối cùng, nếu mã hàng không nằm ở cuối vd như quạt điện J137M hàng mới 100% thì sao?

Bạn gửi ví dụ đấy lên mình xem nhé

 

[le thi thuy 3013]

Bạn gửi ví dụ đấy lên mình xem nhé

Bạn xem giúp mình với, hú hú, nhầm là file dưới này nè snow25

 

[snow25]

Bạn xem giúp mình với, hú hú, nhầm là file dưới này nè snow25

Đây bạn xem code

Sub laygiatri()
Dim arr, arr1
Dim dic As Object
Dim i As Long, a As Long, j As Long
Dim dk As String, dks As String
Set dic = CreateObject("scripting.dictionary")
With Sheet4
    arr1 = .Range("a1:a" & .Range("a" & Rows.Count).End(xlUp).Row).Value
End With
With Sheet1
    arr = .Range("a2:b" & .Range("a" & Rows.Count).End(xlUp).Row).Value
    For i = 1 To UBound(arr, 1)
       dk = arr(i, 1)
       For j = 1 To UBound(arr1, 1)
          dks = "*" & arr1(j, 1) & "*"
          If dk Like dks Then
             arr(i, 2) = arr1(j, 1)
           Exit For
          End If
       Next j
    Next i
    .Range("a2").Resize(i - 1, 2).Value = arr
End With
End Sub

 

[SA_DQ]

Nhờ sửa giúp em với. Em muốn tìm kiếm trong cột A của sheet 1 các mã hàng trong sheet 2 rồi đưa các mã này sang cột B. Em chạy thử thì chạy được vài dòng rồi báo lỗi "Application-defined or object defined error"

Nếu là mình thì mình viết vầy:

Sub GPE_Macro()
 Dim sRng As Range, Rng As Range, Cls As Range
 Dim Rws As Long:                                   Dim MyAdd As String
 On Error GoTo LoiCT
 With Sheet1
1    Rws = .[A2].CurrentRegion.Rows.Count
2    Set Rng = .[A1].Resize(Rws)
 End With
 For Each Cls In Sheet4.Range(Sheet4.[A1], Sheet4.[A1].End(xlDown))
    Set sRng = Rng.Find(Cls.Value, , xlFormulas, xlPart)
3    If Not sRng Is Nothing Then
        MyAdd = sRng.Address
5        Do
            sRng.Offset(, 1).Value = Cls.Value
7            Set sRng = Rng.FindNext(sRng)
        Loop While sRng.Address <> MyAdd
9    End If
 Next Cls
Err_:               Exit Sub
LoiCT:
    MsgBox Error, , Erl
    Resume Err_
End Sub

 

[le thi thuy 3013]

Nếu là mình thì mình viết vầy:

Sub GPE_Macro()
Dim sRng As Range, Rng As Range, Cls As Range
Dim Rws As Long:                                   Dim MyAdd As String
On Error GoTo LoiCT
With Sheet1
1    Rws = .[A2].CurrentRegion.Rows.Count
2    Set Rng = .[A1].Resize(Rws)
End With
For Each Cls In Sheet4.Range(Sheet4.[A1], Sheet4.[A1].End(xlDown))
    Set sRng = Rng.Find(Cls.Value, , xlFormulas, xlPart)
3    If Not sRng Is Nothing Then
        MyAdd = sRng.Address
5        Do
            sRng.Offset(, 1).Value = Cls.Value
7            Set sRng = Rng.FindNext(sRng)
        Loop While sRng.Address <> MyAdd
9    End If
Next Cls
Err_:               Exit Sub
LoiCT:
    MsgBox Error, , Erl
    Resume Err_
End Sub

cảm ơn bạn nhiều nha, mình chạy ok rồi, yeh yeh