Có đoạn code nào biến mọi thao tác dán thành Paste Values không? (1 người xem)

nghiaphuc đã viết:

Mình có làm một chương trình quản lý điểm cho trường và mình gặp một vấn đề như sau:
Trong bảng tính, mình đã định dạng nhất quán khung, nền, font chữ, cỡ chữ, CF,... rồi, nhưng khi giáo viên copy điểm từ file điểm cá nhân của họ vào chương trình (vì đây là chương trình dùng chung cho tất cả các môn, các lớp) thì những định dạng ban đầu của mình thường bị biến đổi. Mặc dù nó chẳng làm thay đổi gì chức năng của chương trình (trừ những thứ liên quan đến Validation) nhưng về mặt thẩm mỹ thì rất khó chịu.
Thực tế thì mình đã hướng dẫn rất nhiều lần về thao tác Paste Values, thậm chí mình còn kéo nút Paste Values lên thanh Menu và đặt phím tắt cho nó, nhưng có lẽ do thói quen khó bỏ nên thường thì giáo viên cứ nhấn nút Paste hoặc nhấn Ctrl+V để dán.
Vậy, xin hỏi: Liệu có đoạn code nào có thể biến mọi thao tác dán thành Paste Values không? Ít nhất là biến 2 thao tác: nhấn nút Paste và nhấn Ctrl+V thành Paste Values.
Rất mong nhận được câu trả lời của các anh, chị, em.
Xin chân thành cảm ơn!

Nhấp chuột vào đây để mở rộng...

Sub Auto_Open()
  Application.OnKey "^v", "PasteValue"
  CommandBars("Cell").Controls("Paste").OnAction = "PasteValue"
  CommandBars("Edit").Controls("Paste").OnAction = "PasteValue"
End Sub

Sub PasteValue()
  Selection.PasteSpecial 3
End Sub

Sub Auto_Close()
  Application.OnKey "^v"
  CommandBars("Cell").Reset
  CommandBars("Edit").Reset
End Sub

ndu96081631 đã viết:

Chắc là phải dùng Onkey thôi

PHP: Sao chép.

Sub Auto_Open()
  Application.OnKey "^v", "PasteValue"
  CommandBars("Cell").Controls("Paste").OnAction = "PasteValue"
  CommandBars("Edit").Controls("Paste").OnAction = "PasteValue"
End Sub

PHP: Sao chép.

Sub PasteValue()
  Selection.PasteSpecial 3
End Sub

Nhấp chuột vào đây để mở rộng...

nghiaphuc đã viết:

Mình có làm một chương trình quản lý điểm cho trường và mình gặp một vấn đề như sau:
Trong bảng tính, mình đã định dạng nhất quán khung, nền, font chữ, cỡ chữ, CF,... rồi, nhưng khi giáo viên copy điểm từ file điểm cá nhân của họ vào chương trình (vì đây là chương trình dùng chung cho tất cả các môn, các lớp) thì những định dạng ban đầu của mình thường bị biến đổi. Mặc dù nó chẳng làm thay đổi gì chức năng của chương trình (trừ những thứ liên quan đến Validation) nhưng về mặt thẩm mỹ thì rất khó chịu.
Thực tế thì mình đã hướng dẫn rất nhiều lần về thao tác Paste Values, thậm chí mình còn kéo nút Paste Values lên thanh Menu và đặt phím tắt cho nó, nhưng có lẽ do thói quen khó bỏ nên thường thì giáo viên cứ nhấn nút Paste hoặc nhấn Ctrl+V để dán.
Vậy, xin hỏi: Liệu có đoạn code nào có thể biến mọi thao tác dán thành Paste Values không? Ít nhất là biến 2 thao tác: nhấn nút Paste và nhấn Ctrl+V thành Paste Values.
Rất mong nhận được câu trả lời của các anh, chị, em.
Xin chân thành cảm ơn!

Nhấp chuột vào đây để mở rộng...

ndu96081631 đã viết:

Chắc là phải dùng Onkey thôi

PHP: Sao chép.

Sub Auto_Open()
Application.OnKey "^v", "PasteValue"
CommandBars("Cell").Controls("Paste").OnAction = "PasteValue"
CommandBars("Edit").Controls("Paste").OnAction = "PasteValue"
End Sub

PHP: Sao chép.

Sub PasteValue()
Selection.PasteSpecial 3
End Sub

Và để reset mấy Action này:

PHP: Sao chép.

Sub Auto_Close()
Application.OnKey "^v"
CommandBars("Cell").Reset
CommandBars("Edit").Reset
End Sub

Nhấp chuột vào đây để mở rộng...

thanhlanh đã viết:

Vẫn còn chổ để dán tại CommandBars("Standard")
Thêm cặp lệnh sau vào cho hết đường dán
Lúc open
Application.CommandBars("Standard").Controls("&Paste").Enabled = False
Lúc Close
Application.CommandBars("Standard").Reset
Hi ... múa rìu qua mắt thợ!

Nhấp chuột vào đây để mở rộng...

Sub Auto_Open()
  Application.OnKey "^v", "PasteValue"
  CommandBars.FindControl(ID:=22).OnAction = "PasteValue"
  CommandBars.FindControl(ID:=6002).Enabled = False
End Sub

ndu96081631 đã viết:

Ai dzà, thằng Paste này nhiều chổ quá, thôi dùng FindControl ha

PHP: Sao chép.

Sub Auto_Open()
  Application.OnKey "^v", "PasteValue"
  CommandBars.FindControl(ID:=22).OnAction = "PasteValue"
  CommandBars.FindControl(ID:=6002).Enabled = False
End Sub

Cũng là 1 cách tham khảo chơi

Nhấp chuột vào đây để mở rộng...

Hong.Van đã viết:

Hiện nay em đang sử dụng code trên cho Excel 2003 thì kết quả rất tốt, nhưng cho Excel 2010 thì Icon (xem hình) này vẫn còn tác dụng, nghĩa là nó không mờ đi (để khỏi bấm nó được nữa)
Thầy cô & anh chị giúp em cho thằng này nó không còn tác dụng nữa được không? Nếu được hay không được, xin vui lòng fản hồi giúp em
Em cảm ơn!

Nhấp chuột vào đây để mở rộng...

MinhKhai đã viết:

Chủ đề đúng mong mỏi của em quá. Nhưng em mới vào diễn đàn nên không làm được như các bác trao đổi với nhau. Bác nào làm sẵn 1 file hay hướng dẫn tỉ mỉ hơn được không?

Nhấp chuột vào đây để mở rộng...

Autpen --> Run)

Mã: Sao chép.

[B]Sub Auto_Open()
    With Application
        .OnKey "^v", "PasteValue"
        .CommandBars.FindControl(ID:=6002).Enabled = False
        .CommandBars("Cell").Controls("Paste").OnAction = "PasteValue"
        .CommandBars("Edit").Controls("Paste").OnAction = "PasteValue"
    End With
End Sub
Sub PasteValue()
    Selection.PasteSpecial 3
End Sub
Sub Auto_Close()
    With Application
        .OnKey "^v"
        .CommandBars("Standard").Reset
        .CommandBars("Cell").Reset
        .CommandBars("Edit").Reset
    End With
End Sub[/B]

thanhlanh đã viết:

- Mở flle Excel muốn thực hiện
- Nhấn Alt + F11
- Trong menu của cửa sổ VBA vào Insert --> Module
- Dán đoạn code sau vào.
- Lưu file, thoát file mở lại file này. (hoặc bấm Alt + F8 --> chọn Macro Autpen --> Run)

Mã: Sao chép.

[B]Sub Auto_Open()
    With Application
        Application.OnKey "^v", "PasteValue"
        .CommandBars.FindControl(ID:=6002).Enabled = False
        .CommandBars("Cell").Controls("Paste").OnAction = "PasteValue"
        CommandBars("Edit").Controls("Paste").OnAction = "PasteValue"
    End With
End Sub
Sub PasteValue()
    Selection.PasteSpecial 3
End Sub
Sub Auto_Close()
    With Application
        .OnKey "^v"
        .CommandBars("Standard").Reset
        .CommandBars("Cell").Reset
        .CommandBars("Edit").Reset
    End With
End Sub[/B]

Nhấp chuột vào đây để mở rộng...

MinhKhai đã viết:

Bác thanhlanh ơi, trong Code trên của bác, chưa khống chế được cách Paste bằng phím Enter. (Em dùng Excel 2003, chưa thử phiên bản khác). Bác hoàn thiện thêm được không ?

Nhấp chuột vào đây để mở rộng...

MinhKhai đã viết:

Bác thanhlanh ơi, trong Code trên của bác, chưa khống chế được cách Paste bằng phím Enter. (Em dùng Excel 2003, chưa thử phiên bản khác). Bác hoàn thiện thêm được không ?

Nhấp chuột vào đây để mở rộng...

Option Explicit
Declare Function SetWindowsHookEx Lib _
                                  "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, _
                                                                      ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Declare Function CallNextHookEx Lib "user32" _
                                (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Declare Function GetActiveWindow Lib "user32" () As Long
Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
                            (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Const HC_ACTION = 0
Const WM_KEYDOWN = &H100
Const WH_KEYBOARD_LL = 13
Dim keyCodeEvent As Long
Dim LenClipboard
Type KBDLLHOOKSTRUCT
    vkCode As Long
    scanCode As Long
    flags As Long
    time As Long
    dwExtraInfo As Long
End Type
Function EnterEvent(ByVal nCode As Long, ByVal wParam As Long, lParam As KBDLLHOOKSTRUCT) As Long
    Dim keyCode As Long
    keyCode = lParam.vkCode
    If GetActiveWindow = FindWindow("XLMAIN", Application.Caption) Then
        If (nCode = HC_ACTION) Then
            If wParam = WM_KEYDOWN Then
                If keyCode = 13 Then
                    LenDataFormClipboard
                    If LenClipboard > 2 Then
                        PasteValue
                        ClearClipboard
                    End If
                End If
            End If
        End If
    End If
    EnterEvent = CallNextHookEx(0, nCode, wParam, ByVal lParam)
End Function
Sub KeyEvent(rng As Range)
    keyCodeEvent = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf EnterEvent, Application.Hinstance, 0)
    'ClearClipboard
End Sub
Public Sub Unhook_KeyBoard()
    If keyCodeEvent <> 0 Then UnhookWindowsHookEx keyCodeEvent
End Sub
' *******************************************************************************
Sub ClearClipboard()
    Dim MyData As Object
    Set MyData = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    MyData.SetText ""
    MyData.PutInClipboard
    Set MyData = Nothing
End Sub
Sub LenDataFormClipboard()
    On Error Resume Next
    With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .GetFromClipboard
        LenClipboard = Len(.GetText)
    End With
End Sub
' *******************************************************************************
' *******************************************************************************
' *******************************************************************************
Sub Auto_Open()
    With Application
        .OnKey "^v", "PasteValue"
        .CommandBars.FindControl(ID:=6002).Enabled = False
        .CommandBars("Cell").Controls("Paste").OnAction = "PasteValue"
        .CommandBars("Edit").Controls("Paste").OnAction = "PasteValue"
    End With
End Sub
Sub PasteValue()
    On Error Resume Next
    Selection.PasteSpecial 3
End Sub
Sub Auto_Close()
    With Application
        .OnKey "^v"
        .CommandBars("Standard").Reset
        .CommandBars("Cell").Reset
        .CommandBars("Edit").Reset
    End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Unhook_KeyBoard
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Unhook_KeyBoard
    KeyEvent Target
End Sub

ndu96081631 đã viết:

Tôi thấy có chiêu này cũng đơn giản đây:
1> Code trong Module

PHP: Sao chép.

Public rng_Old As Range
Sub PutDataToClipboard()
  Dim aSrc, Arr(), tmp()
  Dim lR As Long, lC As Long
  Dim Text As String
  On Error Resume Next
  If TypeOf rng_Old Is Range Then
    If rng_Old.Count = 1 Then
      Text = rng_Old.Value
    Else
      aSrc = rng_Old.Value
      ReDim tmp(1 To UBound(aSrc, 2))
      ReDim Arr(1 To UBound(aSrc, 1))
      For lR = 1 To UBound(aSrc, 1)
        For lC = 1 To UBound(aSrc, 2)
          tmp(lC) = aSrc(lR, lC)
        Next
        Arr(lR) = Join(tmp, vbTab)
      Next
      Text = Join(Arr, vbCrLf)
    End If
    With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
      .SetText Text
      .PutInClipboard
    End With
  End If
End Sub

2> Code trong Sheet

PHP: Sao chép.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Application.CutCopyMode = 0 Then Set rng_Old = Selection
  If Application.CutCopyMode Then PutDataToClipboard
End Sub

Code viết ở mức đơn giản nhất, chắc còn phải cải tiến thêm nữa

Nhấp chuột vào đây để mở rộng...

Sub PutDataToClipboard()
Dim Text As String, a As Object
    On Error Resume Next
    Set a = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    With a
        .GetFromClipboard
        Text = .GetText
    End With
    Set a = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    With a
        .SetText Text
        .PutInClipboard
    End With
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Application.CutCopyMode Then PutDataToClipboard
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Application.CutCopyMode Then ChangeClipboardData
End Sub

Private Const GMEM_MOVEABLE As Long = &H2
Private Const GMEM_DDESHARE As Long = &H2000
Private Const CF_UNICODETEXT = 13
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
    (Destination As Any, Source As Any, ByVal Length As Long)
    
Sub ChangeClipboardData()
Dim hData As Long, pData As Long, size As Long, hNewData As Long, pNewData As Long
    If OpenClipboard(0) = 0 Then Exit Sub
    
    hData = GetClipboardData(CF_UNICODETEXT)
    If hData <> 0 Then
        pData = GlobalLock(hData)
        size = GlobalSize(hData)
        
        hNewData = GlobalAlloc(GMEM_MOVEABLE Or GMEM_DDESHARE, size)
        pNewData = GlobalLock(hNewData)
        CopyMemory ByVal pNewData, ByVal pData, size
        GlobalUnlock hData
        GlobalUnlock hNewData
        
        EmptyClipboard
        SetClipboardData CF_UNICODETEXT, hNewData
    End If
    CloseClipboard
End Sub

siwtom đã viết:

Ừ thì cải tiến. Triết lý đơn giản thôi. Trong Clipboard dữ liệu có thể ở nhiều dạng khác nhau. Vd. khi ta copy vào Clipboard một bảng (vùng dữ liệu có các đường kẻ ô) thì trong clipboard dữ liệu đồng thời có ở dạng: HTML, Rich Edit text, text Unicode, text OEM, CSV (hơi bị nhiều dạng) v...v
Tất nhiên các dạng HTML, Rich Edit text v...v có chứa format (mầu chữ, các đường kẻ, chữ nghiêng ...) còn dạng CSV và text unicode, text OEM là chỉ có chữ mà thôi.
Vậy ta đọc từ clipboard ra dạng text, rồi cái text "nguyên chất" kia ta lại "nạp" vào clipboard. Các dạng có trước sẽ bị xóa - cái "nạp" kia là thao tác copy dữ liệu mới vào clipboard.

Nhấp chuột vào đây để mở rộng...

siwtom đã viết:

Mã: Sao chép.

Sub PutDataToClipboard()
Dim Text As String, a As Object
    On Error Resume Next
    Set a = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    With a
        .GetFromClipboard
        Text = .GetText
    End With
    Set a = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    With a
        .SetText Text
        .PutInClipboard
    End With
End Sub

Nhấp chuột vào đây để mở rộng...

Sub PutDataToClipboard()
Dim Text As String
    On Error Resume Next
    With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .GetFromClipboard
        Text = .GetText
        .Clear
        .SetText Text
        .PutInClipboard
    End With
End Sub

Hong.Van đã viết:

Các Thầy cho em hỏi, có cách nào để code ở modele kg? File có mấy chục Sheet & mỗi lần thêm sheet mới thì fải thêm sự kiện.
Em cảm ơn!

Nhấp chuột vào đây để mở rộng...

Hong.Van đã viết:

Ý em là thế này, lấy ví dụ code của Thầy Siwtom ở bài #17

Mã: Sao chép.

Sub PutDataToClipboard()
......................
.PutInClipboard
End With
End Sub

Code trên chép vào Module
Để code thực thi ở các sheet, thì ta fải chép code dưới vào tất cả các sheet

Mã: Sao chép.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Application.CutCopyMode Then PutDataToClipboard
End Sub

Như vậy có bao nhiêu Sheet thì fải chép code trên vào. Ý em nói có cách nào để khỏi chép vào nhiều Sheet?
Em cảm ơn

Nhấp chuột vào đây để mở rộng...

Sub PutDataToClipboard()
  Dim Text As String
  On Error Resume Next
  With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    .GetFromClipboard
    Text = .GetText
    .Clear
    .SetText Text
    .PutInClipboard
  End With
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
  On Error Resume Next
  If Application.CutCopyMode Then PutDataToClipboard
End Sub

ndu96081631 đã viết:

Nhân đây xin đố mọi người 1 câu: Làm sao có thể xây dựng code trên thành 1 Add-In với các tính năng như sau:
- Khi Add-In được kích hoạt, lập tức sẽ có 1 button xuất hiện trên toolbar
- Khi nhấn vào Button, sự kiện PasteValue sẽ được khởi động
- Nhấn vào Button lần nữa sẽ tắt sự kiện PasteValue
------------------
Chưa làm nhưng tôi biết chắc là làm được. Các bạn thử xem nha!

Nhấp chuột vào đây để mở rộng...

Private WithEvents ExcelApp As Excel.Application

Private Sub Class_Terminate()
    Set ExcelApp = Nothing
End Sub

Public Sub DoCreate(ByVal ExcelApplication As Excel.Application)
    If ExcelApp Is Nothing Then Set ExcelApp = ExcelApplication
End Sub

Private Sub ExcelApp_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    On Error Resume Next
    If Not DoStandard And Application.CutCopyMode Then PutDataToClipboard
End Sub

Public DoStandard As Boolean
Dim ExcelEvents As clsExcelEvents

Private Sub Auto_Open()
... tạo menu có Caption = "Paste Value", OnAction = "Hichic"
..
     Set ExcelEvents = New clsExcelEvents
     ExcelEvents.DoCreate Application
End Sub

Private Sub Auto_Close()
    xóa menu
    ...
     Set ExcelEvents = Nothing
End Sub

Private Sub Hichic()
     DoStandard = Not DoStandard
... đổi qua lại Caption thành "Standard Paste" hoặc "Paste Value"
End Sub

Sub PutDataToClipboard()
    Dim Text As String
    On Error Resume Next
    With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .GetFromClipboard
        Text = .GetText
        .Clear
        .SetText Text
        .PutInClipboard
    End With
End Sub

siwtom đã viết:

Tôi lười nên không test gì cả, còn hướng chắc là thế này:
Insert 1 class Module và 1 Module

Nhấp chuột vào đây để mở rộng...

Public WithEvents ExlApp As Application
Private Sub Class_Initialize()
  Set ExlApp = Application
End Sub

Private Sub Class_Terminate()
  Set ExlApp = Nothing
End Sub

Private Sub ExlApp_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
  On Error Resume Next
  If Application.CutCopyMode Then PutDataToClipboard
End Sub

Dim ExlObj As New clsExcelEvents
Sub Event_Start()
  If ExlObj Is Nothing Then Set ExlObj = New clsExcelEvents
  With Application.CommandBars(1).Controls("Start Paste Values")
    .Caption = "Reset"
    .OnAction = "Event_Stop"
    .FaceId = 47
  End With
End Sub

Sub Event_Stop()
  Set ExlObj = Nothing
  With Application.CommandBars(1).Controls("Reset")
    .Caption = "Start Paste Values"
    .OnAction = "Event_Start"
    .FaceId = 22
  End With
End Sub

Sub PutDataToClipboard()
  Dim Text As String
  On Error Resume Next
  With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    .GetFromClipboard
    Text = .GetText
    .Clear
    .SetText Text
    .PutInClipboard
  End With
End Sub

Sub Auto_Open()
  On Error Resume Next
  With Application.CommandBars(1)
    .Reset
    With .Controls.Add(1)
      .Caption = "Start Paste Values"
      .OnAction = "Event_Start"
      .FaceId = 22
    End With
  End With
End Sub

Sub Auto_Close()
  On Error Resume Next
  Event_Stop
  Application.CommandBars(1).Reset
End Sub

ndu96081631 đã viết:

Nhân đây xin đố mọi người 1 câu: Làm sao có thể xây dựng code trên thành 1 Add-In với các tính năng như sau:
- Khi Add-In được kích hoạt, lập tức sẽ có 1 button xuất hiện trên toolbar
- Khi nhấn vào Button, sự kiện PasteValue sẽ được khởi động
- Nhấn vào Button lần nữa sẽ tắt sự kiện PasteValue
------------------
Chưa làm nhưng tôi biết chắc là làm được. Các bạn thử xem nha!

Nhấp chuột vào đây để mở rộng...

Private WithEvents ExcelApp As Excel.Application 
Private Sub Class_Terminate()
    Set ExcelApp = Nothing
End Sub
Public Sub DoCreate(ByVal ExcelApplication As Excel.Application)
    If ExcelApp Is Nothing Then Set ExcelApp = ExcelApplication
End Sub
Private Sub ExcelApp_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    On Error Resume Next
    If Application.CutCopyMode Then PasteFromClipboard
End Sub

Public Bool As Boolean, ItemButton As Integer
Dim ExcelEvents As clsExcelEvents
Sub Auto_Open()
    On Error Resume Next
    ItemButton = Application.CommandBars("Standard").Controls.Count + 1
    Application.CommandBars("Standard").Controls.Add Type:=msoControlButton, ID _
                                                                           :=18, Before:=ItemButton, Parameter:=True, temporary:=True
    With Application.CommandBars("Standard").Controls.Item(ItemButton)
        .OnAction = "SetButton"
        .TooltipText = "Exit Paste to Paste Value"
        .FaceId = 59
        .Caption = "GPE"
    End With
    Set ExcelEvents = New clsExcelEvents
    ExcelEvents.DoCreate Application
End Sub
Sub SetButton()
    'ItemButton = Application.CommandBars("Standard").Controls.Count
    Bool = Application.CommandBars("Standard").Controls("GPE").Parameter
    Bool = Not (Bool)
   Application.CommandBars("Standard").Controls("GPE").Parameter = Bool
    If Bool Then
        TooltipButton = "Exit Paste to Paste Value"
    Else
        TooltipButton = "Set Paste to Paste Value"
        CreateObject("HTMLfile").ParentWindow.ClipboardData.SetData "text", ""
    End If
   Application.CommandBars("Standard").Controls("GPE").TooltipText = TooltipButton
End Sub
Sub PasteFromClipboard()
    Bool = Application.CommandBars("Standard").Controls("GPE").Parameter
    If Bool = False Then Exit Sub
    Dim objData As Object, sData As String
    On Error Resume Next
    Set objData = CreateObject("HTMLfile")
    sData = objData.ParentWindow.ClipboardData.GetData("text")
    objData.ParentWindow.ClipboardData.SetData "text", Chr(32) & sData
    Set objData = Nothing
End Sub
Sub Auto_Close()
    Set ExcelEvents = Nothing
    Application.CommandBars("Standard").Controls("GPE").Delete
End Sub

ndu96081631 đã viết:

Em làm chắc cũng gần giống cái của anh...

Nhấp chuột vào đây để mở rộng...

Hoàng Trọng Nghĩa đã viết:

Khi chuyển qua cục gôm thì nó paste value, khi chuyển lại nó cũng paste value, lẽ ra khi chuyển lại: hoặc nó mất paste (CutCopyMode=False) hoặc phải paste toàn bộ nội dung copy (value, format...).

Nhấp chuột vào đây để mở rộng...

ndu96081631 đã viết:

Khi bấm nút để reset, đương nhiên bạn phải copy lại cái mới thì mới paste được bình thường chứ
Để nguyên vậy sao mà paste được ---> clipboard đã bị nạp thứ khác rồi (xem code tự hiểu nhé)

Nhấp chuột vào đây để mở rộng...

Hoàng Trọng Nghĩa đã viết:

Vì vậy nên chỉ cần thêm Application.CutCopyMode=False sau khi bấm reset để bắt buộc người ta thấy nút paste chìm xuống thì tự nhiên người ta copy lại thôi. Chứ nó vẫn cứ trơ trơ người ta lại paste tiếp. Ý em là vậy mà!

Nhấp chuột vào đây để mở rộng...

ndu96081631 đã viết:

Thêm sao? Hổng ấy Nghĩa thêm vào code rồi đưa lên đây tôi xem thử

Nhấp chuột vào đây để mở rộng...

Hoàng Trọng Nghĩa đã viết:

Dĩ nhiên em chỉ góp ý, chứ chưa biết phải thêm ở đâu:

Ta thêm 1 biến Boolean, isReset chẳng hạn khi ta bấm nút Reset thì nó trả về True rồi trong thủ tục clipboar ta cho nó nó ".Clear" nội dung rồi trả về isReset=False lại. Hoặc dùng thủ tục CommandBars("Paste").Enable = False để không cho Paste nữa v.v...

Chỉ là gợi ý chứ trình độ của Thầy em biết là có thể biến chuyển để thực hiện được điều đó.

Nhấp chuột vào đây để mở rộng...

Sub Event_Stop()
  Set ExlObj = Nothing
  With Application.CommandBars(1).Controls("Reset")
    .Caption = "Start Paste Values"
    .OnAction = "Event_Start"
    .FaceId = 22
  End With
[COLOR=#ff0000]  OpenClipboard (0&)
  EmptyClipboard
  CloseClipboard[/COLOR]
End Sub

ndu96081631 đã viết:

Nếu muốn vậy thì Nghĩa dùng API mà làm, chẳng hạn:

Mã: Sao chép.

Sub Event_Stop()
  Set ExlObj = Nothing
  With Application.CommandBars(1).Controls("Reset")
    .Caption = "Start Paste Values"
    .OnAction = "Event_Start"
    .FaceId = 22
  End With
[COLOR=#ff0000] [B] OpenClipboard (0&)[/B]
[/COLOR]  EmptyClipboard
  CloseClipboard
End Sub

Cái màu đỏ là 3 hàm API
Nói chung là tôi thấy cũng chẳng quan trọng gì (chỉ là râu ria)

Nhấp chuột vào đây để mở rộng...

Hoàng Trọng Nghĩa đã viết:

Sao em bấm nút nó báo lỗi tại dòng màu đỏ vậy Thầy? (Sub or Function not defined)

Nhấp chuột vào đây để mở rộng...

Public Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function EmptyClipboard Lib "user32.dll" () As Long
Public Declare Function CloseClipboard Lib "user32" () As Long

ndu96081631 đã viết:

Trời ơi!
Thế trong code đã có 3 hàm này chưa:

Mã: Sao chép.

Public Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function EmptyClipboard Lib "user32.dll" () As Long
Public Declare Function CloseClipboard Lib "user32" () As Long

Phải tự cho vào chứ

Nhấp chuột vào đây để mở rộng...

Hoàng Trọng Nghĩa đã viết:

Trời, sao em biết được chứ! Thầy đưa lên thứ gì thì xài thứ đó thôi. Em chỉ là người "test hộ" thôi à! hahahaha

Nhấp chuột vào đây để mở rộng...

ndu96081631 đã viết:

Cái màu đỏ là 3 hàm API

Nhấp chuột vào đây để mở rộng...

ndu96081631 đã viết:

Ở trên đã nói rõ rồi còn gì

Thậm chỉ code ở trên cũng tô màu để gây chú ý luôn rồi
Ẹc...Ẹc...
-------------
Ah, mà Nghĩa test trên Excel nào vậy? Nếu dùng Excel 2003, có thể vui lòng chụp hình cái menu ấy post lên đây cho tôi nhìn thấy hình dáng nó ra làm sao được không?
(dùng Excel 2010 nên không hình dùng được với Excel 2003 thì cái menu ấy nó thế nào nữa)

Nhấp chuột vào đây để mở rộng...

Hoàng Trọng Nghĩa đã viết:

Test trên 2003 Thầy ơi:

Nhấp chuột vào đây để mở rộng...

Hoàng Trọng Nghĩa đã viết:

TTo Admin: dạo này sao chuyển hình lên đây bằng nút Insert Image sao không được (From URL), để ý rất nhiều lần trong thời gian gần đây rồi!

Nhấp chuột vào đây để mở rộng...

ndu96081631 đã viết:

Thì ra cái "mẹt" nó như thế ---> Nhìn cũng "ngồ ngộ" quá chứ (Excel 2007 và 2010, mấy cái menu ấy nó cho vào 1 tab mới có tên là Add-Ins)
Ẹc... Ẹc...

Nhấp chuột vào đây để mở rộng...

ndu96081631 đã viết:

Xem bài này nhé:
http://www.giaiphapexcel.com/forum/showthread.php?72088-Không-thể-Edit-hình-đã-post

Nhấp chuột vào đây để mở rộng...

Hoàng Trọng Nghĩa đã viết:

Từ khi có dãy Ribbon thì mọi menu, toolbar tự tạo nó đều nhóm vào một tab Add-Ins tất cả, trừ khi dùng ngôn ngữ java để can thiệp lên Ribbon.



Theo hướng dẫn thì đã làm được, tuy nhiên có quá nhiều "công cụ" bị lỗi hoặc "nửa vời", BQT cũng nên test lại, nếu dùng được thì show ra, còn không (như table, như insert image ...) thì ẩn các chức năng này luôn cho rồi.

Nhấp chuột vào đây để mở rộng...

Good-Luck đã viết:

2007 thì mình ko nhớ vì ko làm qua việc thêm công cụ, nhưng 2010 thì khác à nha, có thể đặt thêm công cụ tự tạo ở mõi nơi, tốt nhất là 1 tab mới mà vị trí tab tuỳ chọn, đặt biệt là các ACE nào thường tạo thêm nút nhấn để chảy các code thì nó vô cùng dễ dàng

vào option ribbbon > khung trái chọn macro, khung phải tuỳ chọn tab, bạn thêm 1 tab mới, sau đó cứ add macro là xong mõi việc mà không cần sự dụng đến java gì hết

Nhấp chuột vào đây để mở rộng...

ndu96081631 đã viết:

Ác cái đây chỉ là thao tác bằng tay! Nếu viết thành code để tự động hóa quá trình thao tác này thì... Ẹc... Ẹc... đếch biết làm thế nào

Nhấp chuột vào đây để mở rộng...

Good-Luck đã viết:

đúng là các bật thầy, đã tiện lợi rồi còn muốn tiện lợi thêm, viết code để nghiêm cứu chứ, nếu bình thường sử dụng thì khi viết được code lại người ta đã lụm đi mất rồi
<code chỉ nên sự dụng trong trường hợp lập lại sử dụng thường xuyên thôi> nhưng nếu các thầy nào đã viết rồi thì cho các em đây xin để học với

Nhấp chuột vào đây để mở rộng...

Hoàng Trọng Nghĩa đã viết:

Từ khi có dãy Ribbon thì mọi menu, toolbar tự tạo nó đều nhóm vào một tab Add-Ins tất cả, trừ khi dùng ngôn ngữ java để can thiệp lên Ribbon.

Nhấp chuột vào đây để mở rộng...

siwtom đã viết:

Nếu ta làm gì đó cho ta thì ta làm bằng tay hoặc bằng code viết trong VBE, tùy theo lựa chọn. Nhưng nếu ta viết cho người khác, cả những người không am tường lắm về phần mềm, thì ta tự làm luôn.
Menu có thể tạo bằng code viết trong VBE, cũng có thể không viết code để tạo menu trong VBE - nhưng phải có code phục vụ click - bằng việc dùng Custom UI Editor. Khi đó có thể thêm menu vào nút Office, vào thẻ đã có sẵn vd. thẻ Home, hoặc thêm thẻ mới vào Ribbon.

À, việc test đến đâu rồi Nghĩa?

Nhấp chuột vào đây để mở rộng...

Hoàng Trọng Nghĩa đã viết:

Anh cho em thêm thời gian kiểm chứng, bởi em chưa phát hiện ra lỗi hoặc nó đã hoàn hảo chăng?

Nhấp chuột vào đây để mở rộng...

ndu96081631 đã viết:

Thật ra không có thứ gì có thể hoàn hảo 100%
Chẳng hạn code mà ta đang quan tâm, nếu ta Ctrl + X (thay vì Ctrl + C) thì.. tính sao?
(Với Copy/Cut/Paste thông thường thì khi Ctrl + X, Excel sẽ không cho phép Paste Special)

Nhấp chuột vào đây để mở rộng...

Hoàng Trọng Nghĩa đã viết:

Chắc Thầy sẽ có ý định cải tiến thêm nữa chứ!? Vì Thầy nhìn xa trông rộng nên thường làm các hàm, thủ tục rất tổng quát.

Nhấp chuột vào đây để mở rộng...

If Application.CutCopyMode Then PutDataToClipboard

If Application.CutCopyMode [COLOR=#ff0000]= xlCopy[/COLOR] Then PutDataToClipboard

aviaiva đã viết:

em đang sử dụng các đoạn code paste value trên rất tiện, tuy nhiên nếu ctr V lần 2 (sau khi copy xong thì báo lỗi) có cách nào fix lỗi này không

Nhấp chuột vào đây để mở rộng...

ndu96081631 đã viết:

Trong topic này có rất nhiều đoạn code, cụ thể bạn đã dùng đoạn code nào, của bạn viết số mấy?

Nhấp chuột vào đây để mở rộng...

aviaiva đã viết:

đây em dùng 3 cái này

[GPECODE=vb]Sub Autpen()
Application.OnKey "^v", "PasteValue"
CommandBars.FindControl(ID:=22).OnAction = "PasteValue"
CommandBars.FindControl(ID:=6002).Enabled = False
End Sub
Sub PasteValue()
Selection.PasteSpecial 3
End Sub
Sub Auto_Close()
With Application
.OnKey "^v"
.CommandBars("Standard").Reset
.CommandBars("Cell").Reset
.CommandBars("Edit").Reset
End With
End Sub[/GPECODE]

nếu ấn 2 lần ctr V thì nó thông báo lỗi

Nhấp chuột vào đây để mở rộng...

ndu96081631 đã viết:

Thế sao bạn không dùng code của những bài viết mới nhất?
Xem file này nhé
Cách dùng:
- Khởi động file, bạn sẽ thấy trên thanh menu có xuất 1 menu mới (nếu dùng Excel 2003) hoặc sẽ thấy 1 tab mới tên là Add-Ins với 1 cái nút (nếu dùng Excel 2007 hoặc Excel 2010)
- Bấm vào nút để kích hoạt sự kiện Paste Values
- Tiến hành thí nghiệm copy gì đó rồi paste sang nơi khác xem có thật sự là nó đang Paste Values không
- Nếu muốn mọi thứ trở về mặc định, bấm nút lần nữa (để reset sự kiện Paste Values)

Nhấp chuột vào đây để mở rộng...

ndhmoney686 đã viết:

Thầy ndu96081631 và các Bạn có thể giúp Em khi mở file nên là nó tự động kích hoạt sự kiện Paste Values được không ạ. (Ko có nhiều lúc Em hay quên) Mong Thầy và các Bạn giúp đỡ Em. Cảm ơn Thầy và các Bạn nhiều!

Nhấp chuột vào đây để mở rộng...

Sub Auto_Open()
  On Error Resume Next
  With Application.CommandBars(1)
    .Reset
    With .Controls.Add(1)
      .Caption = "Start Paste Values"
      .OnAction = "Event_Start"
      .FaceId = 22
    End With
  End With
End Sub

Sub Auto_Open()
  On Error Resume Next
  With Application.CommandBars(1)
    .Reset
    With .Controls.Add(1)
      .Caption = "Start Paste Values"
      .OnAction = "Event_Start"
      .FaceId = 22
    End With
  End With
  [COLOR=#ff0000][B]Event_Start[/B][/COLOR]
End Sub

congaco đã viết:

Em xin lỗi vì đã đào mộ vì em không biết làm thế nào để có thể làm được trên file exel của em. Em đã thử copy toàn bộ code qua file của mình, save dưới định dạng .xlsm và nhận được lỗi:
View attachment 170547

Kính nhờ các anh / chị giúp đỡ hướng dẫn em với ạ.

Nhấp chuột vào đây để mở rộng...

congaco đã viết:

Chào mọi người. Chúc cả nhà ngày mới tốt lành ạ.
Cảm ơn thầyndu96081631 đã quan tâm ạ. Em Bookmark topic này mà không để ý rằng post của em là cuối của trang nên tưởng không ai quan tâm luôn
Trong post trước em post hình lớn nhưng showroom tự resize hình. Em post lại lỗi và đính kèm file trong post này, nhờ thầy giúp em ạ. Em xin cảm ơn.
View attachment 170644

Nhấp chuột vào đây để mở rộng...

ndu96081631 đã viết:

1> Code trong Module

PHP: Sao chép.

Sub PutDataToClipboard()
  Dim Text As String
  On Error Resume Next
  With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    .GetFromClipboard
    Text = .GetText
    .Clear
    .SetText Text
    .PutInClipboard
  End With
End Sub

2> Code trong Thisworkbook

PHP: Sao chép.

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
  On Error Resume Next
  If Application.CutCopyMode Then PutDataToClipboard
End Sub

Vậy thôi

Nhấp chuột vào đây để mở rộng...

thanhtratt đã viết:

Cái này có sử dụng được trên Excel 2019 không? Sao mình làm rồi mà khi Pase không có tác dụng?

Nhấp chuột vào đây để mở rộng...

hungtin1997 đã viết:

Sao không dùng Quick Access để gán nút dán Value lên Ribbon. Gán vào phím Alt+1 rồi dán thôi.
View attachment 249420

Nhấp chuột vào đây để mở rộng...

ndu96081631 đã viết:

Nếu nguồn copy nằm ở chỗ khác (trên 1 trang web chẳng hạn) thì liệu có dùng cách của bạn được không?

Nhấp chuột vào đây để mở rộng...

hungtin1997 đã viết:

Dạ em tưởng làm việc chỉ trong Excel thưa thầy, với lại nếu dán từng ô thì F2 rồi dán vẫn ổn mà thầy.

Nhấp chuột vào đây để mở rộng...

nghiaphuc đã viết:

Thực tế thì mình đã hướng dẫn rất nhiều lần về thao tác Paste Values, thậm chí mình còn kéo nút Paste Values lên thanh Menu và đặt phím tắt cho nó, nhưng có lẽ do thói quen khó bỏ nên thường thì giáo viên cứ nhấn nút Paste hoặc nhấn Ctrl+V để dán.
Vậy, xin hỏi: Liệu có đoạn code nào có thể biến mọi thao tác dán thành Paste Values không? Ít nhất là biến 2 thao tác: nhấn nút Paste và nhấn Ctrl+V thành Paste Values.
Rất mong nhận được câu trả lời của các anh, chị, em.
Xin chân thành cảm ơn!

Nhấp chuột vào đây để mở rộng...

ndu96081631 đã viết:

Ngoài ra thì tác giả bài viết có nói rằng:

Bạn thấy nhu cầu của người ta có hợp lý không?

Nhấp chuột vào đây để mở rộng...

hungtin1997 đã viết:

Dạ nếu vấn đề ở thói quen sao không xử lí thói quen đó nhỉ. Em xin lỗi, nếu như thói quen đó của các thầy cô không sửa được thì em sẽ tạo 1 sheet phụ để họ dán Ctr+V vào và link qua sheet form bên kia. Em chỉ khai thác hết các công cụ của Excel trước khi nhờ mọi người code.

Nhấp chuột vào đây để mở rộng...

ndu96081631 đã viết:

Thế sao bạn không dùng code của những bài viết mới nhất?
Xem file này nhé
Cách dùng:
- Khởi động file, bạn sẽ thấy trên thanh menu có xuất 1 menu mới (nếu dùng Excel 2003) hoặc sẽ thấy 1 tab mới tên là Add-Ins với 1 cái nút (nếu dùng Excel 2007 hoặc Excel 2010)
- Bấm vào nút để kích hoạt sự kiện Paste Values
- Tiến hành thí nghiệm copy gì đó rồi paste sang nơi khác xem có thật sự là nó đang Paste Values không
- Nếu muốn mọi thứ trở về mặc định, bấm nút lần nữa (để reset sự kiện Paste Values)

Nhấp chuột vào đây để mở rộng...

kan1231 đã viết:

thay ndu ơi, sao e mở file lên test thử lúc paste lại k hiện ra value thế ạView attachment 249455

Nhấp chuột vào đây để mở rộng...

ndu96081631 đã viết:

Trước đó bạn copy cái gì?

Nhấp chuột vào đây để mở rộng...