להורדה | תוסף לאקסל למי שעושה הרבה פעמים העתק הדבק |מדביק אוטמטי

[דנבו]

מכירים את זה שאתם מעתיקים מכל מיני מקומות לאקסל וכל פעם צריכים לעשות העתק הדבק. התוסף הזה הוא בכל פעם שאתה לוחץ העתק הוא מדביק אוטמטית בקוביה הראשונה הפנויה בעמודה 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

עכשיו סוגרים את החלון חוזרים לאקסל מציירים צורה כלשהיא לוחצים כפתור ימני

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

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

[מטעמים]

@דנבו

כדאי שתכיר את זה.

[Whenever]

וגם כדאי שתכירו את WIN + V שזה נותן גישה ללוח של וינדוס.
טעמו וראו כי טוב.

[דנבו]

@Whenever כתב בלהורדה | תוסף לאקסל למי שעושה הרבה פעמים העתק הדבק |מדביק אוטמטי:

וגם כדאי שתכירו את WIN + V שזה נותן גישה ללוח של וינדוס.
טעמו וראו כי טוב.

אבל לא בזה מדובר גם כשאתה לוחץ ווינדוס V אתה צריך ללחוץ עליו , התוסך הזה מדביק ישר אחרי הCTRL C בלי ללחוץ על כלום

[דנבו]

@מטעמים כתב בלהורדה | תוסף לאקסל למי שעושה הרבה פעמים העתק הדבק |מדביק אוטמטי:

@דנבו

כדאי שתכיר את זה.

לא קשור למה שאני עשיתי

[מטעמים]

@דנבו כתב בלהורדה | תוסף לאקסל למי שעושה הרבה פעמים העתק הדבק |מדביק אוטמטי:

לא קשור למה שאני עשיתי

0

לפני 4 ימים

מה המטרה במה שיצרת?

שיהיה לך ארכיון מסודר של כל ההעתקות? לא?

[דנבו]

@מטעמים כתב בלהורדה | תוסף לאקסל למי שעושה הרבה פעמים העתק הדבק |מדביק אוטמטי:

@דנבו כתב בלהורדה | תוסף לאקסל למי שעושה הרבה פעמים העתק הדבק |מדביק אוטמטי:

לא קשור למה שאני עשיתי

0

לפני 4 ימים

מה המטרה במה שיצרת?

שיהיה לך ארכיון מסודר של כל ההעתקות? לא?

נגיד אתה יוצר קובץ אם כל מיני נתונים ואתה רוצה להוסיף לקובץ נתונים מכל מיני מקומות

[pcinfogmach]

@דנבו
עיין כאן אולי יהיה שימושי עבורך:
https://mitmachim.top/topic/54139/מדריך-מדריך-איך-להכין-תוסף-לוורד-בקלות

זה עובד כמובן גם באקסל ואפילו יותר טוב מוורד.