crisreis

Caros programadores, Gostaria que alguém me ajudasse a corrigir este código. Minha intenção é colocar o texto na tabela, célula (2,2). Qualquer ajuda é bem-vinda. O arquivo original está em: http://www.4shared.com/document/mgde22MJ/r...io_final_2.html E o código segue abaixo: Sub TextInTable() Dim oSection As Section Dim oRange As Range Dim StartWord As String, EndWord As String StartWord = "Nome" EndWord = "Caminho" If ActiveDocument.Sections.Count > 0 Then For Each oSection In ActiveDocument.Sections Set oRange = oSection.Range oRange.Select With ActiveDocument.Content.Duplicate oRange.Find.Execute Findtext:=StartWord & "*" & EndWord, MatchWildcards:=True oRange.MoveStart wdCharacter, 0 oRange.MoveEndUntil vbCr oRange.Cut oRange.Tables(1).Cell(2, 2).Paste End With Next oSection End If End Sub

Oi,Nelson, Bom dia!! Ok, eu também vou tentando outras pequenas macros para ver se acontece alguma coisa. Obrigado e qualquer ajuda é bem-vinda. Cristina Reis

Oi, Nelson, o link para o arquivo original é: http://www.4shared.com/document/ryo2K6lF/I...crostestes.html Coloquei apenas 4 imagens, mas em geral estes relatórios têm mais de 20. Se você puder rodar a macro que eu postei, dá para ter uma ideia do que eu desejo, pois a única coisa que falta é colocar o texto que se refere à imagem ao lado dela, ou seja, na segunda coluna. O link para a versão final é: http://www.4shared.com/document/sFBRQnOq/r...orio_final.html Obrigado pelo interesse Cristina Reis

Oi, Nelson, que satisfação que você tenha se interessado. Neste meu caso, eu recebo o documento original no Word já com a imagem, e no Excel a imagem não aparece, apenas o nome do arquivo, por isso, desde sempre, eu pensei em trabalhar em cima de uma macro para o Word. Mas se der para ser no excel, também resolve. Obrigado pela atenção.

Caros programadores, teria como, usando VBA colocar estes texto na segunda coluna de uma tabela. Cada texto deste tem uma imagem correspondente. A imagem eu consegui colocar na primeira coluna, mas o texto não. Se puderem me ajudar agradeço. Abaixo está o código que eu tento adaptar para minha necessidade. Nome: Background.jpg Tipo: Jpeg Tamanho: 48.94 KB Caminho: /private/var/mobile/Library/ ---------------------------------- Nome: IMG_0001.THM Tipo: Jpeg Tamanho: 4.19 KB Caminho: /private/var/mobile/Media/DCIM/100APPLE/ ----------------------------- Nome: IMG_0002.JPG Tipo: Jpeg Tamanho: 318.18 KB MetaDados: EquipMake: Apple EquipModel: iPhone XResolution: 72.000000 YResolution: 72.000000 ResolutionUnit: 2 DateTime: 2009:07:07 12:27:58 GpsLatitudeRef: S GpsLongitudeRef: W GpsGpsTime: 12.000000 27.000000 29.840000 Caminho: /private/var/mobile/Media/DCIM/100APPLE/ ------------------------------ Nome: P200010_13.30.jpg Tipo: Jpeg Tamanho: 1.09 MB MetaDados: EquipMake: LG Electronics EquipModel: KP570 SoftwareUsed: LGE_SW Caminho: External/Pictures ------------------------ Nome: P060410_19.02.jpg Tipo: Jpeg Tamanho: 265.68 KB MetaDados: EquipMake: LG Electronics EquipModel: KP570 SoftwareUsed: LGE_SW Caminho: External/Pictures ----------------------- Nome: Z000410_12.28.jpg Tipo: Jpeg Tamanho: 1.11 MB MetaDados: EquipMake: LG Electronics EquipModel: KP570 SoftwareUsed: LGE_SW Caminho: External/Pictures ----------------- Sub macro1000() Dim j As Integer Dim i As Long Dim search As String Dim txt As String Dim para As paragraph Selection.WholeStory ActiveDocument.Content.ParagraphFormat.TabStops.ClearAll Selection.ClearFormatting 'Format text With Selection.Font ' the Latin text font name and size. .Name = "Verdana" .Size = 10 ' Bold and Italic are the Font Style... .Bold = False .Italic = True .Underline = wdUnderlineNone .UnderlineColor = wdColorAutomatic End With 'Format paragraphs. With Selection.ParagraphFormat .LeftIndent = CentimetersToPoints(0) .RightIndent = CentimetersToPoints(0) .SpaceBefore = 0 .SpaceBeforeAuto = False .SpaceAfter = 0 .SpaceAfterAuto = False .LineSpacingRule = wdLineSpaceAtLeast .LineSpacing = 12 .Alignment = wdAlignParagraphLeft .WidowControl = True .KeepWithNext = False .KeepTogether = False .PageBreakBefore = False .NoLineNumber = False .Hyphenation = True .FirstLineIndent = CentimetersToPoints(0) .OutlineLevel = wdOutlineLevelBodyText .CharacterUnitLeftIndent = 0 .CharacterUnitRightIndent = 0 .CharacterUnitFirstLineIndent = 0 .LineUnitBefore = 0 .LineUnitAfter = 0 End With ‘Delete tabs. Dim oRng As Word.Range Set oRng = ActiveDocument.Range With oRng.Find .ClearFormatting .Text = "^t" While .Execute oRng.Delete Wend End With 'Resize pictures > 500 pixels. Set DocThis = ActiveDocument iILShapeCount = DocThis.InlineShapes.Count For j = 1 To iILShapeCount If PointsToPixels(DocThis.InlineShapes(j).Width, False) > 500 Then ActiveDocument.InlineShapes(j).Height = _ ActiveDocument.InlineShapes(j).Height / 2 ActiveDocument.InlineShapes(j).Width = _ ActiveDocument.InlineShapes(j).Width / 2 End If Next ‘Imagens - put border. Set DocThis = ActiveDocument iILShapeCount = DocThis.InlineShapes.Count For k = 1 To iILShapeCount With Selection.InlineShapes(k) With .Borders(wdBorderLeft) .LineStyle = wdLineStyleSingle .LineWidth = wdLineWidth100pt .Color = wdColorAutomatic End With With .Borders(wdBorderRight) .LineStyle = wdLineStyleSingle .LineWidth = wdLineWidth100pt .Color = wdColorAutomatic End With With .Borders(wdBorderTop) .LineStyle = wdLineStyleSingle .LineWidth = wdLineWidth100pt .Color = wdColorAutomatic End With With .Borders(wdBorderBottom) .LineStyle = wdLineStyleSingle .LineWidth = wdLineWidth100pt .Color = wdColorAutomatic End With .Borders.Shadow = False End With With Options .DefaultBorderLineStyle = wdLineStyleSingle .DefaultBorderLineWidth = wdLineWidth100pt .DefaultBorderColor = wdColorAutomatic End With Next 'Delete data without interesting. search = "Exif" For i = ActiveDocument.Paragraphs.Count To 2 Step -1 ActiveDocument.Paragraphs(i).Range.Select txt = ActiveDocument.Paragraphs(i).Range.Text If InStr((txt), search) Then ActiveDocument.Paragraphs(i).Range.Delete End If Next search = "JPEG" For i = ActiveDocument.Paragraphs.Count To 2 Step -1 ActiveDocument.Paragraphs(i).Range.Select txt = ActiveDocument.Paragraphs(i).Range.Text If InStr((txt), search) Then ActiveDocument.Paragraphs(i).Range.Delete End If Next search = "Image" For i = ActiveDocument.Paragraphs.Count To 2 Step -1 ActiveDocument.Paragraphs(i).Range.Select txt = ActiveDocument.Paragraphs(i).Range.Text If InStr((txt), search) Then ActiveDocument.Paragraphs(i).Range.Delete End If Next search = "Orientation" For i = ActiveDocument.Paragraphs.Count To 2 Step -1 ActiveDocument.Paragraphs(i).Range.Select txt = ActiveDocument.Paragraphs(i).Range.Text If InStr((txt), search) Then ActiveDocument.Paragraphs(i).Range.Delete End If Next 'Put blank paragraphs and add a table and add a reference to section break (BP). For i = ActiveDocument.Paragraphs.Count To 2 Step -1 ActiveDocument.Paragraphs(i).Range.Select If ActiveDocument.Paragraphs(i).Range.Characters.Count = 1 Then Selection.TypeParagraph Selection.TypeParagraph Selection.TypeParagraph Selection.Tables.Add Range:=Selection.Range, NumRows:=2, NumColumns:=2 Selection.Tables.Item(1).Cell(1, 1).Column.Width = 220 Selection.Tables.Item(1).Cell(1, 2).Column.Width = 220 Selection.Tables.Item(1).Cell(1, 1).Range.Text = "Imagem" Selection.Tables.Item(1).Cell(1, 2).Range.Text = "Dados de Exif" Selection.TypeText Text:=".BP " Selection.TypeParagraph End If Next ‘Add section break For Each para In ActiveDocument.Paragraphs If para.Range.Words.first = "." Then If para.Range.Words(2) = "BP " Then para.Range.InsertBreak Type:=wdSectionBreakContinuous para.Range.Words.first.Delete para.Range.Words.first.Delete para.Range.Delete End If End If Next para With ActiveDocument .Sections.first.Range.Delete End With With ActiveDocument .Sections.first.Range.Delete End With With ActiveDocument .Sections.Last.Range.Delete End With With ActiveDocument.Sections.first.Range .Collapse direction:=wdCollapseEnd .InsertAfter "IMAGENS" End With ‘Put imagens inside the table iShapeCount = DocThis.InlineShapes.Count For i = 1 To iShapeCount ActiveDocument.InlineShapes(i).Range.Select With Selection .Cut DocThis.Tables(i).Cell(2, 1).Range.Paste End With Next i End Sub