Private Sub Test()
Dim iList As Worksheet, iTextBox As TextBox
For Each iList In ThisWorkbook.Worksheets
For Each iTextBox In iList.TextBoxes
For iCount% = 1 To iTextBox.Characters.Count Step 255
iText$ = iText$ & iTextBox.Characters(Start:=iCount%).Text
Next
MsgBox iText$, , iList.Name: iText$ = ""
Next
Next
End Sub
не могу вытянуть весь текст из Shapes()
Вопрос такой:
нужно из Shapes() объекта вытащить весь текст. но тем методом, что я представил ниже вытягивается лишь первых 255 символов. пытался разбивать .Characters(1,200).Text ... + Characters(201,100).Text + ... и т.д. но всё равно 255 символов, причём начальный символ не может быть больше 255. помогите решить проблему. заранее спасибо!!!
---------------------------------------------
Dim sh As Worksheet
Dim list_name As String
Dim j As Integer
Dim comm(30) As String
Dim list_names(30) As String
Dim bb As Integer
j = 1
For Each sh In Workbooks("Provision report UA 2009.xls").Worksheets
list_name = sh.name
list_names(j) = list_name
comm(j) = sh.Shapes("TextBox 1").TextFrame.Characters.Text
bb = Len(comm(j))
j = j + 1
Next sh
-----------------------------------------------------
нужно из Shapes() объекта вытащить весь текст. но тем методом, что я представил ниже вытягивается лишь первых 255 символов. пытался разбивать .Characters(1,200).Text ... + Characters(201,100).Text + ... и т.д. но всё равно 255 символов, причём начальный символ не может быть больше 255. помогите решить проблему. заранее спасибо!!!
---------------------------------------------
Dim sh As Worksheet
Dim list_name As String
Dim j As Integer
Dim comm(30) As String
Dim list_names(30) As String
Dim bb As Integer
j = 1
For Each sh In Workbooks("Provision report UA 2009.xls").Worksheets
list_name = sh.name
list_names(j) = list_name
comm(j) = sh.Shapes("TextBox 1").TextFrame.Characters.Text
bb = Len(comm(j))
j = j + 1
Next sh
-----------------------------------------------------
Код:
P.S. Нумерация элементов массива, по умолчанию, начинается с 0
Спасибо. оч. помогло!
Подскажите где ошибка!
Sub copy_comments3()
Dim mass() As String
Dim list_name() As String
Dim shape_name() As String
ReDim mass(100) As String
ReDim list_name(100) As String
ReDim shape_name(100) As String
Dim sh3 As Worksheet, iShape As Shape
i% = 1
' загоняю в массив коментарии из одной книги
For Each sh3 In Workbooks("Provision report UA 2009.xls").Worksheets
For Each iShape In sh3.Shapes
For iCount% = 1 To iShape.TextFrame.Characters.Count Step 255
iText$ = iText$ & iShape.TextFrame.Characters(Start:=iCount%).Text
Next
mass(i%) = iText$
shape_name(i%) = iShape.name
list_name(i%) = sh3.name
iText$ = ""
i% = i% + 1
Next
Next
lenth% = i% - 1
ReDim mass(lenth%) As String
ReDim list_name(lenth%) As String
ReDim shape_name(lenth%) As String
Dim sh4 As Worksheet, iShape4 As Shape
Dim shape_name4 As String
Dim sh_name4 As String
' пытаюсь в ставить в другую книгу коментарии при совпадении имён 'листов и шэйпов. книги одинаковые по структуре.
For Each sh4 In Workbooks("Provision report UA 2009ppp.xls").Worksheets
sh_name4 = sh4.name
For Each iShape4 In sh4.Shapes
shape_name4 = iShape4.name
For j% = 1 To lenth%
' сравниваю имена листов массива и имена листов книги в которую надо 'вставить из массива данные
If InStr(1, sh_name4, list_name(j%), vbTextCompare) <> 0 Then
' сравниваю имена шэйпов массива и имена шэйпов листа в который надо 'вставить текст шэйпов
If InStr(1, shape_name4, shape_name(j%), vbTextCompare) <> 0 Then
'заменяю текст в Shape на текст из массива но там пусто, хотя 'элементы массива выше были не пустые
iShape4.TextFrame.Characters.Text = mass(j%)
End If
End If
Next j%
Next iShape4
Next sh4
End Sub
Sub copy_comments3()
Dim mass() As String
Dim list_name() As String
Dim shape_name() As String
ReDim mass(100) As String
ReDim list_name(100) As String
ReDim shape_name(100) As String
Dim sh3 As Worksheet, iShape As Shape
i% = 1
' загоняю в массив коментарии из одной книги
For Each sh3 In Workbooks("Provision report UA 2009.xls").Worksheets
For Each iShape In sh3.Shapes
For iCount% = 1 To iShape.TextFrame.Characters.Count Step 255
iText$ = iText$ & iShape.TextFrame.Characters(Start:=iCount%).Text
Next
mass(i%) = iText$
shape_name(i%) = iShape.name
list_name(i%) = sh3.name
iText$ = ""
i% = i% + 1
Next
Next
lenth% = i% - 1
ReDim mass(lenth%) As String
ReDim list_name(lenth%) As String
ReDim shape_name(lenth%) As String
Dim sh4 As Worksheet, iShape4 As Shape
Dim shape_name4 As String
Dim sh_name4 As String
' пытаюсь в ставить в другую книгу коментарии при совпадении имён 'листов и шэйпов. книги одинаковые по структуре.
For Each sh4 In Workbooks("Provision report UA 2009ppp.xls").Worksheets
sh_name4 = sh4.name
For Each iShape4 In sh4.Shapes
shape_name4 = iShape4.name
For j% = 1 To lenth%
' сравниваю имена листов массива и имена листов книги в которую надо 'вставить из массива данные
If InStr(1, sh_name4, list_name(j%), vbTextCompare) <> 0 Then
' сравниваю имена шэйпов массива и имена шэйпов листа в который надо 'вставить текст шэйпов
If InStr(1, shape_name4, shape_name(j%), vbTextCompare) <> 0 Then
'заменяю текст в Shape на текст из массива но там пусто, хотя 'элементы массива выше были не пустые
iShape4.TextFrame.Characters.Text = mass(j%)
End If
End If
Next j%
Next iShape4
Next sh4
End Sub
Речь действительно идёт о комментариях (Вставка - Примечание) или под термином комментарии Вы подразумеваете некие графические об'екты, содержащие текст, к примеру, текстовые поля (Вид - Панели инструментов - Рисование - Поле) ...
Если первое, то лучше использовать семейство Comments, т.к. это позволяет избежать "проблемы" 255 символов, если второе, то лучше мучить семейство TextBoxes, ибо семейство Shapes содержит все графические об'екты.
Что касается добавления текста, то там также существует ограничение на 255 символов, которое можно обойти, если использовать
P.S. Достаточно ReDim Массив(1 To Лист.Shapes.Count) As String
Если первое, то лучше использовать семейство Comments, т.к. это позволяет избежать "проблемы" 255 символов, если второе, то лучше мучить семейство TextBoxes, ибо семейство Shapes содержит все графические об'екты.
Что касается добавления текста, то там также существует ограничение на 255 символов, которое можно обойти, если использовать
Код:
iText$ = Application.Rept("Текст, содержащий более 255 символов ", 10)
With ThisWorkbook.Worksheets(1).TextBoxes(1)
For iCount% = 1 To Len(iText$) Step 255
.Characters(iCount%).Insert String:=Mid(iText$, iCount%, 255)
Next
End With
With ThisWorkbook.Worksheets(1).TextBoxes(1)
For iCount% = 1 To Len(iText$) Step 255
.Characters(iCount%).Insert String:=Mid(iText$, iCount%, 255)
Next
End With
P.S. Достаточно ReDim Массив(1 To Лист.Shapes.Count) As String
ещё раз спасибо! окончательный вариант получился такой
// макрос копирует комменты из одной книги в другую (структура книг совпадает)
// макрос копирует комменты из одной книги в другую (структура книг совпадает)
Код:
Sub copy_comments()
Dim mass() As String
Dim list_name() As String
Dim shape_name() As String
ReDim mass(100) As String
ReDim list_name(100) As String
ReDim shape_name(100) As String
Dim sh As Worksheet, iShape As Shape
i% = 1
For Each sh In Workbooks("Provision report UA 2009.xls").Worksheets
For Each iShape In sh.Shapes
For icount% = 1 To iShape.TextFrame.Characters.Count Step 255
iText$ = iText$ & iShape.TextFrame.Characters(Start:=icount%).Text
Next
mass(i%) = iText$
shape_name(i%) = iShape.Name
list_name(i%) = sh.Name
iText$ = ""
i% = i% + 1
Next
Next
lenth% = i% - 1
' ReDim mass(lenth%) As String
' ReDim list_name(lenth%) As String
' ReDim shape_name(lenth%) As String
Dim sh2 As Worksheet, iShape2 As Shape
For Each sh2 In Workbooks("Provisions UA_work").Worksheets
For Each iShape2 In sh2.Shapes
For i% = 1 To lenth%
If ((InStr(1, list_name(i%), sh2.Name, vbTextCompare) <> 0) And (InStr(1, shape_name(i%), iShape2.Name, vbTextCompare) <> 0)) Then
iShape2.TextFrame.Characters.Text = ""
strTemp$ = mass(i%)
lngPos% = 1
Do While Len(strTemp$) > 255
iShape2.TextFrame.Characters(lngPos%, 255).Text = Left(strTemp$, 255)
lngPos% = lngPos% + 255
strTemp = Mid(strTemp$, lngPos%)
Loop
iShape2.TextFrame.Characters(lngPos%, 255).Text = Left(strTemp$, 255)
End If
Next
Next
Next
End Sub
Dim mass() As String
Dim list_name() As String
Dim shape_name() As String
ReDim mass(100) As String
ReDim list_name(100) As String
ReDim shape_name(100) As String
Dim sh As Worksheet, iShape As Shape
i% = 1
For Each sh In Workbooks("Provision report UA 2009.xls").Worksheets
For Each iShape In sh.Shapes
For icount% = 1 To iShape.TextFrame.Characters.Count Step 255
iText$ = iText$ & iShape.TextFrame.Characters(Start:=icount%).Text
Next
mass(i%) = iText$
shape_name(i%) = iShape.Name
list_name(i%) = sh.Name
iText$ = ""
i% = i% + 1
Next
Next
lenth% = i% - 1
' ReDim mass(lenth%) As String
' ReDim list_name(lenth%) As String
' ReDim shape_name(lenth%) As String
Dim sh2 As Worksheet, iShape2 As Shape
For Each sh2 In Workbooks("Provisions UA_work").Worksheets
For Each iShape2 In sh2.Shapes
For i% = 1 To lenth%
If ((InStr(1, list_name(i%), sh2.Name, vbTextCompare) <> 0) And (InStr(1, shape_name(i%), iShape2.Name, vbTextCompare) <> 0)) Then
iShape2.TextFrame.Characters.Text = ""
strTemp$ = mass(i%)
lngPos% = 1
Do While Len(strTemp$) > 255
iShape2.TextFrame.Characters(lngPos%, 255).Text = Left(strTemp$, 255)
lngPos% = lngPos% + 255
strTemp = Mid(strTemp$, lngPos%)
Loop
iShape2.TextFrame.Characters(lngPos%, 255).Text = Left(strTemp$, 255)
End If
Next
Next
Next
End Sub
Ещё раз повторюсь, если речь действительно идёт о комментариях (Вставка - Примечание), то в таком случае "проблема" 255 символов не актуальна, ибо существует семейство Comments (см. далее)
P.S. Предполагается, что имена графических об'ектов (Comment, Shape), в каждом листе, уникальны.
Код:
Private Sub Test()
Dim iList As Worksheet, iComment As Comment
Dim iArchive$(), iCount&, iText 'As Variant
For Each iList In Workbooks("Книга_Источник.xls").Worksheets
ReDim Preserve iArchive(1, iCount + iList.Comments.Count - 1)
For Each iComment In iList.Comments
iArchive(0, iCount) = iList.Name & "!" & iComment.Shape.Name
iArchive(1, iCount) = iComment.Text
iCount = iCount + 1
Next
Next
Application.ScreenUpdating = False
For Each iList In Workbooks("Книга_Приемник.xls").Worksheets
For Each iComment In iList.Comments
iText = Application.HLookup(iList.Name & _
"!" & iComment.Shape.Name, iArchive, 2, 0)
If Not IsError(iText) Then iComment.Text iText
Next
Next
Application.ScreenUpdating = True
End Sub
Dim iList As Worksheet, iComment As Comment
Dim iArchive$(), iCount&, iText 'As Variant
For Each iList In Workbooks("Книга_Источник.xls").Worksheets
ReDim Preserve iArchive(1, iCount + iList.Comments.Count - 1)
For Each iComment In iList.Comments
iArchive(0, iCount) = iList.Name & "!" & iComment.Shape.Name
iArchive(1, iCount) = iComment.Text
iCount = iCount + 1
Next
Next
Application.ScreenUpdating = False
For Each iList In Workbooks("Книга_Приемник.xls").Worksheets
For Each iComment In iList.Comments
iText = Application.HLookup(iList.Name & _
"!" & iComment.Shape.Name, iArchive, 2, 0)
If Not IsError(iText) Then iComment.Text iText
Next
Next
Application.ScreenUpdating = True
End Sub
P.S. Предполагается, что имена графических об'ектов (Comment, Shape), в каждом листе, уникальны.
Нет. речь идёт не только о комментариях (Вставка - Примечание), но и графических объектах, содержащих текст.
ps
интересный вариант решения:
ps
интересный вариант решения:
Код:
iText = Application.HLookup(iList.Name & _
"!" & iComment.Shape.Name, iArchive, 2, 0)
"!" & iComment.Shape.Name, iArchive, 2, 0)
В таком случае Вам, видимо, не избежать дополнительных телодвижений касающихся получения/ввода полного текста (конечно, если Вы не собираетесь копировать и вставлять графические об'екты, ибо в этом случае также можно избежать уже неоднократно упомянутой "проблемы" 255 символов)
А если серьёзно, то не все графические об'екты имеют текст, и стоит только, к примеру, установить автофильтр (что формально не изменит структуру) как в процессе выполнения макроса Вы получите ошибку, которую можно избежать, если добавить проверку типа графического об'екта.
А если серьёзно, то не все графические об'екты имеют текст, и стоит только, к примеру, установить автофильтр (что формально не изменит структуру) как в процессе выполнения макроса Вы получите ошибку, которую можно избежать, если добавить проверку типа графического об'екта.