להורדה | תוסף לאקסל למי שעושה הרבה פעמים העתק הדבק |מדביק אוטמטי
-
מכירים את זה שאתם מעתיקים מכל מיני מקומות לאקסל וכל פעם צריכים לעשות העתק הדבק. התוסף הזה הוא בכל פעם שאתה לוחץ העתק הוא מדביק אוטמטית בקוביה הראשונה הפנויה בעמודה 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 שזה נותן גישה ללוח של וינדוס.
טעמו וראו כי טוב.אבל לא בזה מדובר גם כשאתה לוחץ ווינדוס V אתה צריך ללחוץ עליו , התוסך הזה מדביק ישר אחרי הCTRL C בלי ללחוץ על כלום
-
@מטעמים כתב בלהורדה | תוסף לאקסל למי שעושה הרבה פעמים העתק הדבק |מדביק אוטמטי:
@דנבו כתב בלהורדה | תוסף לאקסל למי שעושה הרבה פעמים העתק הדבק |מדביק אוטמטי:
לא קשור למה שאני עשיתי
0
לפני 4 ימים
מה המטרה במה שיצרת?
שיהיה לך ארכיון מסודר של כל ההעתקות? לא?
נגיד אתה יוצר קובץ אם כל מיני נתונים ואתה רוצה להוסיף לקובץ נתונים מכל מיני מקומות
-
@דנבו
עיין כאן אולי יהיה שימושי עבורך:
https://mitmachim.top/topic/54139/מדריך-מדריך-איך-להכין-תוסף-לוורד-בקלותזה עובד כמובן גם באקסל ואפילו יותר טוב מוורד.