Блог

При создании текстовых полей в Excel невозможно использовать функцию поиска текста.

Excel не будет выполнять поиск текста, содержащегося в текстовых полях.

Это огромное ограничение для кого-то вроде меня, у которого более 500 текстовых полей разбросаны по нескольким листам.

Я видел много сообщений людей, предлагающих решения, которые никоим образом не равны или не заменяют оригинальную функцию Excel «найти текст».

Например:

https://superuser.com/questions/1367712/find-text-in-the-textbox-in-excel
https://excel.tips.net/T011281_Finding_Text_in_Text_Boxes.html

Я собираюсь поделиться здесь своим решением, надеясь помочь и другим.

Что делает этот код vba: он экспортирует все фигуры (включая текстовые поля) в новый документ word.

В Word функция поиска действительно работает в текстовых полях, и проблема решена.

Это единственное решение, равное поврежденной функции поиска текста в Excel.

 Sub Export()
' THIS must be enabled in Excel: Developer > Visual basic > Tools > References > Microsoft word 1x Object library
'Known bug: if the worksheet has only 1 textbox it will mess up the copy to word. You can manually fix it by adding another textbox in that worksheet. It can be empty.
'Ctrl break -> will stop the process
'If Word crashes -> the clipboard size is too large.
'Reduce the sheet size or split it in 2 sheets.
'The clipboard limitation is an excel wide limitation.
    
Dim StartTime As Double
Dim MinutesElapsed As String
StartTime = Timer

MsgBox " Wait for job completed textbox in excel!" amp; vbCrLf amp; "Close any other WORD files!"
Dim WordApp As Word.Application
Dim i As Integer
Dim sourceSheet As Worksheet
Set sourceSheet = ActiveSheet
Application.ScreenUpdating = False
Sheet1.Activate
Set WordApp = CreateObject("Word.Application")
On Error Resume Next
WordApp.Documents.Add
    With WordApp.ActiveDocument.PageSetup
            .PageWidth = InchesToPoints(22)
            .PageHeight = InchesToPoints(22)
    End With

WordApp.ActiveWindow.View.Type = wdWebView

WordApp.Visible = True
WordApp.Application.ScreenUpdating = False
WS_Count = ActiveWorkbook.Worksheets.Count

For i = 1 To WS_Count
    ActiveWorkbook.Sheets(i).Activate
    ActiveWorkbook.Sheets(i).Shapes.SelectAll
    Selection.Copy

PasteChartIntoWord WordApp

If i <> WS_Count Then
    With WordApp.Selection
        .Collapse Direction:=0
        .InsertBreak Type:=7
    End With
End If

Application.CutCopyMode = False

Next i
' Text in textboxes -> apply style: nospacing so that text fits in the textboxes in Word

  Dim objTextBox As Object
  Dim objDoc As Object
  Set objDoc = GetObject(, "Word.Application").ActiveDocument
  For Each objTextBox In objDoc.Shapes
  If objTextBox.TextFrame.HasText Then
  objTextBox.TextFrame.TextRange.ParagraphFormat.LineSpacingRule = 0
  objTextBox.TextFrame.TextRange.ParagraphFormat.SpaceAfter = 0
  End If
  Next objTextBox



Call sourceSheet.Activate
Application.ScreenUpdating = True
WordApp.Application.ScreenUpdating = True


'Determine how many seconds code took to run
  MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
'Notify user in seconds
  MsgBox "Done! " amp; MinutesElapsed amp; " minutes", vbInformation
 End Sub




 Function PasteChartIntoWord(WordApp As Object) As Object

' Remove textbox selection
ActiveCell.Select
  Range("BB100").Select
  ActiveWindow.SmallScroll up:=100
  ActiveWindow.SmallScroll ToLeft:=44

' create a header with sheetname for quick referencing!
WordApp.Selection.ParagraphFormat.Alignment = wdAlignParagraphRight
WordApp.Selection.Font.Size = 36
WordApp.Selection.Font.Underline = wdUnderlineSingle
WordApp.Selection.Font.ColorIndex = wdRed
WordApp.Selection.TypeText Text:=ActiveSheet.Name

' Paste the textboxes
WordApp.Selection.PasteSpecial DataType:=wdPasteShape

End Function