пока не успокоился - ищу варианты сейчас так 1)- есть кнопка макроса Вставить из буфера обмена и стандартный copy/past в меню excel 2) - есть режим просто выделить ячейку и режим редактирования ячейки (вызывается по двойному клику на ячейку или F2 - появляется курсор в ячейке)
Задача:при копировании текста из браузера или иных источников в ячейку текст очищался ( копировались только значения и освобождаемся от переносов и лишних пробелов) при этом: 1 задача: выделили просто ячейку - копируемый текст вставляется в пустую ячейку или в конец текста по макросу (кнопке) с форматированием - это решено 2 задача выделили ячейку вошли в режим редактирования ячейки и вставляем копируемый текст в любое место курсора стандартным copy/past (макросом не получается сплошные конфликты в разных вариациях) - решено частично - вставляется и не конфликтует но форматирования из стандартного буфера обмена не удалось достичь - тк нужно лезть в WinApi писать функцию с форматированием текста и применять к активной ячейке если вставляем текст стандартным copy/past
Файл с примером во вложении ( макрос в лист ) - ежели кто поможет доработать буду рад
Код
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Function GetTxtFromCB()
On Error Resume Next
With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.GetFromClipboard
GetTxtFromCB = .GetText
GetTxtFromCB = Replace(GetTxtFromCB, Chr(10), " ")
GetTxtFromCB = Replace(GetTxtFromCB, Chr(13), " ")
GetTxtFromCB = Application.WorksheetFunction.Trim(GetTxtFromCB)
End With
End Function
Private Sub ClearClipborad()
OpenClipboard 0
EmptyClipboard
CloseClipboard
End Sub
Sub ClipBoardPast() ' Вставить скопированное в текст активной ячейки в столбец B
Application.EditDirectlyInCell = False 'запретить редактирование в ячейках
Const sRANGE = "B4:B1000"
If Not Intersect(ActiveCell, Range(sRANGE)) Is Nothing Then
Dim s As String
s = GetTxtFromCB
On Error Resume Next
Application.ScreenUpdating = False
Application.EnableEvents = False
If ActiveCell.Value = "" Then
Application.ActiveCell.Value = s
Else
Application.ActiveCell.Value = Application.ActiveCell.Text & " " & s
End If
Application.ActiveCell.Text = Replace(ActiveCell.Text, Chr(10), " ")
Application.ActiveCell.Text = Replace(ActiveCell.Text, Chr(13), " ")
Application.ActiveCell.Text = Application.WorksheetFunction.Trim(ActiveCell.Text)
Selection.NumberFormat = "@"
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection.Font
.Name = "Calibri"
.FontStyle = "обычный"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
Application.EnableEvents = True
Application.ScreenUpdating = True
End If
ClearClipborad ' очистить буфер обмена
Application.EditDirectlyInCell = True 'разрешить редактирование в ячейках
End Sub
нашел Application.EditDirectlyInCell = False Application.EditDirectlyInCell = True запретить /разрешить редактирование в ячейках но к сожалению как условие на режим редактирования не подходят ...
так то вроде понятна последовательность действий 1.если ячейка пуста то Application.ActiveCell.Value = s 2.Если ячейка непуста И НЕ НАХОДИТСЯ В РЕЖИМЕ РЕДАКТИРОВАНИЯ (просто выделена) то Application.ActiveCell.Value = Application.ActiveCell.Text & " " & s 3.Если ячейка непуста И НАХОДИТСЯ В РЕЖИМЕ РЕДАКТИРОВАНИЯ то Application.SendKeys ("^v") на макрос - тогда и вставка по курсору получается
но как условие сделать - если ячейка находится в режиме редактирования (если ячейка просто выделена и не находится в режиме редактирования) не знаю ...
стандартный copy/past вставляет же текст в положение курсора в ячейке - как же привязать GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") на курсор ?
вставка текста в место положения курсора в тексте в ячейке - заметил что у ячейки 2 режима работы - просто выделенная ячейка и в тексте ячейки курсор мигает последний макрос который ранее выкладывал работает когда просто выделенная ячейка а вот если в тексте ячейки курсор мигает - макрос не срабатывает
Как понять эти 2 события - они разные первый - это Private Sub Workbook_SheetChange - просто выделяем ячейку а второе событие - в тексте ячейки курсор - это что тогда ? как привязаться к вставке на курсор в тексте ячейки ?
чтото форум лагает - пишу ответы по 2-3 раза - не проходят Сделал макросом Глобальная задача - стандартным copy/past сделать копирование только текста повисла в воздухе .. (стандартным copy/past - дело в том что даже при использовании GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") все равно дубль копирования лезет в нижние строки)
Единственное что недоделал - это вставка текста в место положения курсора в тексте в ячейке - если курсор активен. Как прописать это условие ?
Код
Const sSHEET_NAME = "Лист1"
Const sRANGE = "B1:B300"
Function GetTxtFromCB()
On Error Resume Next
With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.GetFromClipboard
GetTxtFromCB = .GetText
GetTxtFromCB = Replace(GetTxtFromCB, Chr(10), " ")
GetTxtFromCB = Replace(GetTxtFromCB, Chr(13), " ")
GetTxtFromCB = Application.WorksheetFunction.Trim(GetTxtFromCB)
End With
End Function
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Sh.Name <> sSHEET_NAME Then Exit Sub
If Not Intersect(Target, Range(sRANGE)) Is Nothing Then
Dim s As String
s = GetTxtFromCB
On Error Resume Next
'Application.ActiveCell.Value = s
Application.ActiveCell.Text = s
End If
End Sub
Sub ClipBoardPast() ' Вставить скопированное в текст активной ячейки в столбец B
Dim s As String
s = GetTxtFromCB
On Error Resume Next
Application.ScreenUpdating = False
Application.EnableEvents = False
If ActiveCell.Value = "" Then
Application.ActiveCell.Value = s
Else
Application.ActiveCell.Value = Application.ActiveCell.Text & " " & s
End If
Application.ActiveCell.Text = Replace(ActiveCell.Text, Chr(10), " ")
Application.ActiveCell.Text = Replace(ActiveCell.Text, Chr(13), " ")
Application.ActiveCell.Text = Application.WorksheetFunction.Trim(ActiveCell.Text)
Selection.NumberFormat = "@"
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection.Font
.Name = "Calibri"
.FontStyle = "обычный"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Jungl большое спасибо за внимание только в вашем макросе Range(sRANGE).Clear подтирает все значения в столбце В - таким способом удаляются дубли строк но при этом в и старые нужные записи потрутся если там было чтото те вставляем значение в активную ячейку - остальные ячейки в B затираются что нежелательно
может по этому пути пойти ? так тоже работает - при вставке помогает Application.Undo освободится от дубля строк но в тоже время он мешает когда стираем ячейку в диапазоне B - возвращает значение старое при удалении. те Application.Undo надо както отменять после вставки в ячейку ( после Application.ActiveCell.Value = s)
Код
EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Const sSHEET_NAME = "Лист1"
Const sRANGE = "B1:B30"
Function GetTxtFromCB()
On Error Resume Next
With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.GetFromClipboard
GetTxtFromCB = .GetText
GetTxtFromCB = Replace(GetTxtFromCB, Chr(10), "")
GetTxtFromCB = Application.WorksheetFunction.Trim(GetTxtFromCB)
End With
End Function
Private Sub ClearClipborad()
OpenClipboard 0
EmptyClipboard
CloseClipboard
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Sh.Name <> sSHEET_NAME Then Exit Sub
If Not Intersect(Target, Range(sRANGE)) Is Nothing Then
Dim s As String
s = GetTxtFromCB
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Undo
Application.ActiveCell.Value = s
' !!!!! как в этом месте отменить Application.Undo ????
Application.EnableEvents = True
Application.ScreenUpdating = True
End If
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
'ClearClipborad
End Sub
Можно и без функции но эффект тотже - плохо работает - строки дубли внизу
Код
Const sSHEET_NAME = "Лист1"
Const sRANGE = "B1:B30"
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Sh.Name <> sSHEET_NAME Then Exit Sub
If Not Intersect(Target, Range(sRANGE)) Is Nothing Then
On Error Resume Next
' this is a late bound MSForms.DataObject
With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.GetFromClipboard
ActiveCell.Value = .GetText
End With
End If
End Sub
Здравствуйте Как скопировать из браузера только текст и вставить его в текст активной ячейки (если имеет текст) или в пустую ячейку (если нет текста) стандартным скопировать/вставить - те вставить только значения текста
Попробовал такой макрос на событие Private Sub Workbook_SheetChange - работает с глюками пример приложил в файл При этом на событие Private Sub Workbook_SheetSelectionChange работает макрос превосходно - как надо а вот на Private Sub Workbook_SheetChange плохо работает ( но получается что надо на Private Sub Workbook_SheetChange чтоб нормально работать).
Код
Const sSHEET_NAME = "Лист1"
Const sRANGE = "B1:B30"
Function GetTxtFromCB()
On Error Resume Next
With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.GetFromClipboard
GetTxtFromCB = .GetText
GetTxtFromCB = Replace(GetTxtFromCB, Chr(10), "")
GetTxtFromCB = Application.WorksheetFunction.Trim(GetTxtFromCB)
End With
End Function
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Sh.Name <> sSHEET_NAME Then Exit Sub
If Not Intersect(Target, Range(sRANGE)) Is Nothing Then
Dim s As String
s = GetTxtFromCB
Application.ActiveCell.Value = s
End If
End Sub