Nhờ sửa mã macro Pastevalue

[xkun2001]

Chào các bạn,
Mình có macro này để paste value từ mọi text từ clipboard vào excel. Nhưng nếu clipboard rỗng thì báo lỗi.
Nhờ các bạn sửa giúp, cám ơn các bạn nhiều!

Sub PasteValue()
'
' Keyboard Shortcut: Ctrl+q
'-------------------
Dim MyDataObj As New DataObject
Dim St
On Error Resume Next
On Error GoTo PA2
    Selection.PasteSpecial Paste:=xlPasteValues
PA2:
    If Err.Number <> 0 Then
        Err.Clear
        On Error GoTo PA3
        MyDataObj.GetFromClipboard
        St = MyDataObj.GetText
        Selection = St
    End If
PA3:
    If Err.Number <> 0 Then
        Err.Clear
        On Error GoTo PA4
        ActiveSheet.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:= _
        False, NoHTMLFormatting:=True
    End If
PA4:
    If Err.Number <> 0 Then
        Err.Clear
        'Nothing
    End If
End Sub

Khi clipboard rỗng mà gọi lệnh thì báo lỗi sau:

 

[Tình nghĩa giang hồ]

Bạn thử code này xem đáp ứng được không nhé.

Sub PasteValue()
    ' Keyboard Shortcut: Ctrl+q
    '-------------------
    Dim MyDataObj As New DataObject
    Dim St
    
    On Error Resume Next
    
      On Error GoTo PA2
    Selection.PasteSpecial Paste:=xlPasteValues
    
PA2:
    If Err.Number <> 0 Then
        Err.Clear
        On Error GoTo PA3
        
        MyDataObj.GetFromClipboard
        St = MyDataObj.GetText
        
        If Len(Trim(St)) > 0 Then
            Selection.Value = St
        End If
    End If
    
PA3:
    If Err.Number <> 0 Then
        Err.Clear
        On Error GoTo PA4
        
        ActiveSheet.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:= _
        False, NoHTMLFormatting:=True
    End If
    
PA4:
    If Err.Number <> 0 Then
        Err.Clear
    End If
End Sub

 

[xkun2001]

Bạn thử code này xem đáp ứng được không nhé.

Sub PasteValue()
    ' Keyboard Shortcut: Ctrl+q
    '-------------------
    Dim MyDataObj As New DataObject
    Dim St
  
    On Error Resume Next
  
      On Error GoTo PA2
    Selection.PasteSpecial Paste:=xlPasteValues
  
PA2:
    If Err.Number <> 0 Then
        Err.Clear
        On Error GoTo PA3
      
        MyDataObj.GetFromClipboard
        St = MyDataObj.GetText
      
        If Len(Trim(St)) > 0 Then
            Selection.Value = St
        End If
    End If
  
PA3:
    If Err.Number <> 0 Then
        Err.Clear
        On Error GoTo PA4
      
        ActiveSheet.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:= _
        False, NoHTMLFormatting:=True
    End If
  
PA4:
    If Err.Number <> 0 Then
        Err.Clear
    End If
End Sub

Cám ơn bạn nhưng lỗi ở dòng "St = MyDataObj.GetText" nếu clipboard empty bạn ạ.


Lỗi run-timer:

 

[Nhattanktnn]

Cám ơn bạn nhưng lỗi ở dòng "St = MyDataObj.GetText" nếu clipboard empty bạn ạ.
View attachment 294270

Lỗi run-timer:
View attachment 294271

Kiểu nó vậy hả :

Sub PasteValue()
' Keyboard Shortcut: Ctrl+q
'-------------------
Dim MyDataObj As New DataObject
Dim St
On Error Resume Next
    Selection.PasteSpecial Paste:=xlPasteValues
    If Err.Number = 0 Then: Exit Sub
PA2:
    Err.Clear
    MyDataObj.GetFromClipboard
    St = MyDataObj.GetText
    Selection = St
    If Err.Number = 0 Then Exit Sub
PA3:
    Err.Clear
    ActiveSheet.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:= _
        False, NoHTMLFormatting:=True
    If Err.Number <> 0 Then MsgBox "Bó tay!"
End Sub

 

[xkun2001]

Kiểu nó vậy hả :

Sub PasteValue()
' Keyboard Shortcut: Ctrl+q
'-------------------
Dim MyDataObj As New DataObject
Dim St
On Error Resume Next
    Selection.PasteSpecial Paste:=xlPasteValues
    If Err.Number = 0 Then: Exit Sub
PA2:
    Err.Clear
    MyDataObj.GetFromClipboard
    St = MyDataObj.GetText
    Selection = St
    If Err.Number = 0 Then Exit Sub
PA3:
    Err.Clear
    ActiveSheet.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:= _
        False, NoHTMLFormatting:=True
    If Err.Number <> 0 Then MsgBox "Bó tay!"
End Sub

Cám ơn bạn. Câu lệnh rỏ ràng hơn hẳn