Страницы: 1
RSS
Скопировать из браузера только текст и вставить в текст ячейки
 
Здравствуйте
Как скопировать из браузера только текст  и вставить его в текст активной ячейки (если имеет текст) или в пустую ячейку (если нет текста)  стандартным скопировать/вставить  - те вставить только значения текста

Попробовал такой макрос  на событие  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
 
Цитата
artem1212 написал:
Скопировать из браузера только текст
Это можно решить методом HTTP запроса. Без браузера. Зависит от сайта.
Если все таки нужно методом копи-паста, то не совсем понимаю, как стандартная вставка вставит в ячейки только текст? У меня вот в буфере всевозможные картинки, дизайн, текст с завитушками - он прямо так и вставляется мне в таблицу. Т.е. изначально в ячейки ВСЕГДА будет вставляться форматированные данные из буфера, а только потом макрос будет их обрабатывать.
p.s. при SheetChange стоит добавить добавить Application.EnableEvents. Остальное по желанию.
Вариант в Worksheet_Change:
Код
Const sRANGE = "B1:B100"
Private Sub Worksheet_Change(ByVal Target As Range)
Dim txt As String
If ActiveCell.Value = "" Then Exit Sub
    If Not Intersect(Target, Range(sRANGE)) Is Nothing Then
        On Error Resume Next
        Application.EnableEvents = False
        Application.ScreenUpdating = False
        Range(sRANGE).Clear
        Set Obj = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        With Obj
            .GetFromClipboard
            txt = .GetText
            txt = Replace(txt, Chr(10), " ")
            txt = Application.WorksheetFunction.Trim(txt)
            ActiveCell.Value = txt
            ActiveCell.Select
        End With
        On Error GoTo 0
        Application.ScreenUpdating = True
        Application.EnableEvents = True
    End If
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
 
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
Изменено: artem1212 - 14.02.2017 22:15:46
 
чтото форум лагает - пишу ответы по 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
Изменено: artem1212 - 19.02.2017 10:23:44
 
Да уж... это антиспам-защита. Чем больше одинаковых сообщений, тем хуже.
Попробуйте изменить текст
 
а чем они одинаковы ? пишу же разное ...
 
вставка текста в место положения курсора в тексте в ячейке  - заметил что у ячейки 2 режима работы  -
просто выделенная ячейка
и в тексте ячейки курсор мигает
последний макрос который ранее выкладывал работает когда просто выделенная ячейка
а вот если в тексте ячейки курсор мигает - макрос не срабатывает

Как понять эти 2 события - они разные
первый - это Private Sub Workbook_SheetChange - просто выделяем ячейку
а второе событие - в тексте ячейки курсор - это что тогда ? как привязаться к вставке на курсор в тексте ячейки ?
Изменено: artem1212 - 18.02.2017 22:55:16
 
Цитата
artem1212 написал:
Private Sub Workbook_SheetChange - просто выделяем ячейку
Нет - это событие ИЗМЕНЕНИЯ значения в ячейке.
а выделение (активация) ячейки - это Worksheet_SelectionChange
А вот когда в ячейке мигающий курсор - ничего не сделаете, пока не закончите редактирование.
 
сам попутал вопрос - Юрий все правильно - выделение ячейки - это Worksheet_SelectionChange

а когда в ячейке или в тексте ячейки мигающий курсор - как в это событие войти чтобы текст вставить на место курсора ?
Изменено: artem1212 - 18.02.2017 23:09:37
 
Думаю, что никак.
 
стандартный copy/past вставляет же текст в положение курсора в ячейке - как же привязать GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")  на курсор ?
Изменено: artem1212 - 18.02.2017 23:18:59
 
Я правда не знаю )
 
так то вроде понятна последовательность действий
1.если ячейка пуста то Application.ActiveCell.Value = s
2.Если ячейка непуста И НЕ НАХОДИТСЯ В РЕЖИМЕ РЕДАКТИРОВАНИЯ (просто выделена)  то Application.ActiveCell.Value = Application.ActiveCell.Text & " " & s
3.Если ячейка непуста И НАХОДИТСЯ В РЕЖИМЕ РЕДАКТИРОВАНИЯ то Application.SendKeys ("^v") на макрос - тогда и вставка по курсору получается

но как условие сделать - если ячейка находится в режиме редактирования  (если ячейка просто выделена и не находится в режиме редактирования) не знаю ...
Изменено: artem1212 - 19.02.2017 10:26:40
 
нашел Application.EditDirectlyInCell = False Application.EditDirectlyInCell = True  запретить /разрешить редактирование в ячейках   но к сожалению как условие на режим редактирования не подходят ...
 
пока не успокоился - ищу варианты  :)
сейчас так
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



Изменено: artem1212 - 21.02.2017 00:59:25
Страницы: 1
Наверх