מכירים את זה שאתם מעתיקים מכל מיני מקומות לאקסל וכל פעם צריכים לעשות העתק הדבק. התוסף הזה הוא בכל פעם שאתה לוחץ העתק הוא מדביק אוטמטית בקוביה הראשונה הפנויה בעמודה A , ואז אתה לא צריך ללחוץ הדבק אחרי כל פעם שמעתיקים משהו | זה תוסף שאני יצרתי
הוראות התקנה:
נכנסים לאקסל לוחצים ALT + F11 מגיעים לחלון הזה

לוחצים כאן

ואז בתיבה שמופיעה מדביקים את הקוד הזה
#If VBA7 Then
Private Declare PtrSafe Function OpenClipboard Lib "User32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function GetClipboardData Lib "User32" (ByVal wFormat As Long) As LongPtr
Private Declare PtrSafe Function CloseClipboard Lib "User32" () As Long
Private Declare PtrSafe Function GlobalLock Lib "Kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalUnlock Lib "Kernel32" (ByVal hMem As LongPtr) As Long
Private Declare PtrSafe Function lstrlenW Lib "Kernel32" (ByVal lpString As LongPtr) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As LongPtr)
#Else
Private Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "User32" (ByVal wFormat As Long) As Long
Private Declare Function CloseClipboard Lib "User32" () As Long
Private Declare Function GlobalLock Lib "Kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "Kernel32" (ByVal hMem As Long) As Long
Private Declare Function lstrlenW Lib "Kernel32" (ByVal lpString As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
#End If
Const CF_UNICODETEXT As Long = 13
Dim isRunning As Boolean
Dim lastClipboard As String
' הפעלת מעקב אחרי לוח ההעתקה
Sub התחלת_מעקב()
isRunning = True
lastClipboard = ""
מעקב_לוח
End Sub
' עצירת מעקב
Sub עצירת_מעקב()
isRunning = False
MsgBox "המעקב אחרי הלוח הופסק.", vbInformation, "תוסף לוח"
End Sub
' פונקציה למעקב אחר לוח ההעתקה - עם עצירה תקינה
Sub מעקב_לוח()
Dim clipboardContent As String
Do While isRunning
clipboardContent = קבלת_לוח
If clipboardContent <> "" And clipboardContent <> lastClipboard Then
lastClipboard = clipboardContent
הדבקה_לשורה_הבאה clipboardContent
End If
DoEvents ' מאפשר עצירה תקינה של הלולאה
Application.Wait (Now + TimeValue("00:00:01")) ' המתנה של שנייה אחת
Loop
End Sub
' פונקציה לקבלת תוכן מהלוח (ללא ActiveX)
Function קבלת_לוח() As String
Dim hClipboard As LongPtr
Dim hMem As LongPtr
Dim lpMem As LongPtr
Dim lSize As Long
Dim sText As String
If OpenClipboard(0&) Then
hMem = GetClipboardData(CF_UNICODETEXT)
If hMem <> 0 Then
lpMem = GlobalLock(hMem)
If lpMem <> 0 Then
lSize = lstrlenW(lpMem) * 2
If lSize > 0 Then
sText = Space$(lSize \ 2)
CopyMemory ByVal StrPtr(sText), ByVal lpMem, lSize
End If
GlobalUnlock hMem
End If
End If
CloseClipboard
End If
קבלת_לוח = sText
End Function
' פונקציה להדבקת הטקסט בשורה הפנויה הבאה בטור A
Sub הדבקה_לשורה_הבאה(text As String)
Dim ws As Worksheet
Set ws = ActiveSheet
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1
ws.Cells(lastRow, 1).Value = text
End Sub
או אם האקסל שלכם באנגלית אז את הקוד הזה
#If VBA7 Then
Private Declare PtrSafe Function OpenClipboard Lib "User32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function GetClipboardData Lib "User32" (ByVal wFormat As Long) As LongPtr
Private Declare PtrSafe Function CloseClipboard Lib "User32" () As Long
Private Declare PtrSafe Function GlobalLock Lib "Kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalUnlock Lib "Kernel32" (ByVal hMem As LongPtr) As Long
Private Declare PtrSafe Function lstrlenW Lib "Kernel32" (ByVal lpString As LongPtr) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As LongPtr)
#Else
Private Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "User32" (ByVal wFormat As Long) As Long
Private Declare Function CloseClipboard Lib "User32" () As Long
Private Declare Function GlobalLock Lib "Kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "Kernel32" (ByVal hMem As Long) As Long
Private Declare Function lstrlenW Lib "Kernel32" (ByVal lpString As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
#End If
Const CF_UNICODETEXT As Long = 13
Dim isRunning As Boolean
Dim lastClipboard As String
' Start clipboard monitoring
Sub StartClipboardMonitor()
isRunning = True
lastClipboard = ""
MonitorClipboard
End Sub
' Stop clipboard monitoring
Sub StopClipboardMonitor()
isRunning = False
MsgBox "Clipboard monitoring stopped.", vbInformation, "Clipboard Tracker"
End Sub
' Function to monitor clipboard changes
Sub MonitorClipboard()
Dim clipboardContent As String
Do While isRunning
clipboardContent = GetClipboardText()
If clipboardContent <> "" And clipboardContent <> lastClipboard Then
lastClipboard = clipboardContent
PasteToNextRow clipboardContent
End If
DoEvents ' Allows immediate stopping of the loop
Application.Wait (Now + TimeValue("00:00:01")) ' Wait for one second
Loop
End Sub
' Function to get clipboard text (without ActiveX)
Function GetClipboardText() As String
Dim hClipboard As LongPtr
Dim hMem As LongPtr
Dim lpMem As LongPtr
Dim lSize As Long
Dim sText As String
If OpenClipboard(0&) Then
hMem = GetClipboardData(CF_UNICODETEXT)
If hMem <> 0 Then
lpMem = GlobalLock(hMem)
If lpMem <> 0 Then
lSize = lstrlenW(lpMem) * 2
If lSize > 0 Then
sText = Space$(lSize \ 2)
CopyMemory ByVal StrPtr(sText), ByVal lpMem, lSize
End If
GlobalUnlock hMem
End If
End If
CloseClipboard
End If
GetClipboardText = sText
End Function
' Function to paste text into the next available row in column A
Sub PasteToNextRow(text As String)
Dim ws As Worksheet
Set ws = ActiveSheet
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1
ws.Cells(lastRow, 1).Value = text
End Sub
עכשיו סוגרים את החלון חוזרים לאקסל מציירים צורה כלשהיא לוחצים כפתור ימני

לוחצים על הקצאת מאקרו לוחצים התחלת מעקב ואישור

עושים צורה שונה ועושים לה עצור מעקב.
זהו עכשיו כל פעם שתלחצו על הצורה זה יתחיל לעבוד , אפשר להוסיף על הצורה כיתוב : התחלת מעקב .