Fóruns
Microsoft Excel - 2...
2024 - VBA & Macros
Formatar Importação
 
Notifications
Clear all

Formatar Importação

 
2024 - VBA & Macros
9 Posts
1 Usuários
0 Reactions
1,883 Visualizações
RSS
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Boa tarde;
tenho um amcro que importa dados do excel para o word sem nenhuma formatação.
tem alguma maneira de importar esse dados ja formatados?
segue o comando.

Sub GerarRelatorio()
   
    Sheets("Relatorio").Activate
    Dim objWord As Variant
    Dim strTexto As String
    Dim Intervalo As Range
    Dim Celula As Range

    Set Intervalo = Range("A1:G10")
    strTexto = ""
    For Each Celula In Intervalo
        strTexto = strTexto & Celula.Value
    Next

    Set objWord = CreateObject("Word.Application")
    objWord.Visible = True
    With objWord
    .Documents.Add Template:="Normal", newtemplate:=False, DocumentType:=0

    .Selection.TypeText Text:=strTexto
    .Selection.TypeParagraph
    .ActiveDocument.SaveAs Filename:="Realatório.doc", FileFormat:= _
    0, LockComments:=False, Password:="", AddToRecentFiles:= _
    True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:= _
    False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
    SaveAsAOCELetter:=False

    End With

    Set objWord = Nothing

    End Sub
 
Postado : 16/07/2011 11:17 am
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Boa tarde,

Veja se esta adaptação do seu código atende:

Sub GerarRelatorio()
   
    Sheets("Relatorio").Activate
    Dim objWord As Variant
    Dim Intervalo As Range

    Set Intervalo = Range("A1:G10")
    Intervalo.Copy
    
    Set objWord = CreateObject("Word.Application")
    objWord.Visible = True
    With objWord
        .Documents.Add Template:="Normal", newtemplate:=False, DocumentType:=0
        .Selection.PasteExcelTable False, False, False
        .Selection.TypeParagraph
        .ActiveDocument.SaveAs Filename:="Relatório.doc", FileFormat:= _
        0, LockComments:=False, Password:="", AddToRecentFiles:= _
        True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:= _
        False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
        SaveAsAOCELetter:=False
    End With
    Set objWord = Nothing
End Sub

Abraço

 
Postado : 14/08/2011 11:10 am
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Perfeitamente Mestre JValq.

Obrigado
Abraço.

 
Postado : 16/08/2011 10:10 am
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

JValq.

Tem Alguma possibilidade dessa macro copiar todos os outros objeto da planilha e não copiar as linhas de grade do Excel?

Aguardo retorno.

 
Postado : 12/09/2011 5:14 pm
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Boa noite,

Quais objetos?
Quanto à grade, se o intervalo copiado não tiver bordas a tabela vai ser copiada desta maneira.

Abraço

 
Postado : 12/09/2011 8:36 pm
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Bom dia.

Seria uma imagem e algumas caixas de textos.

Aguardo retorno.

 
Postado : 13/09/2011 6:13 am
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Bom dia,

Supondo que sejam 4 objetos, veja se o código abaixo atende:

Sub GerarRelatorio()
   
    Sheets("Relatorio").Activate
    Dim objWord As Variant
    Dim Intervalo As Range

    Set Intervalo = Range("A1:G10")
    Intervalo.Copy
    
    Set objWord = CreateObject("Word.Application")
    objWord.Visible = True
    With objWord
        .Documents.Add Template:="Normal", newtemplate:=False, DocumentType:=0
        .Selection.PasteExcelTable False, False, False
        .Selection.TypeParagraph
        .ActiveDocument.SaveAs Filename:="Relatório.doc", FileFormat:= _
        0, LockComments:=False, Password:="", AddToRecentFiles:= _
        True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:= _
        False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
        SaveAsAOCELetter:=False
    End With
    
    ActiveSheet.Shapes.Range(Array(1, 2, 3, 4)).Select
    Selection.Copy
    objWord.Selection.Paste
    
    Set objWord = Nothing
End Sub

Abraço

 
Postado : 14/09/2011 6:47 am
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Para qualquer quantidade de objetos:

Sub GerarRelatorio()
   
    Sheets("Relatorio").Activate
    Dim objWord As Variant
    Dim Intervalo As Range

    Set Intervalo = Range("A1:G10")
    Intervalo.Copy
    
    Set objWord = CreateObject("Word.Application")
    objWord.Visible = True
    With objWord
        .Documents.Add Template:="Normal", newtemplate:=False, DocumentType:=0
        .Selection.PasteExcelTable False, False, False
        .Selection.TypeParagraph
        .ActiveDocument.SaveAs Filename:="Relatório.doc", FileFormat:= _
        0, LockComments:=False, Password:="", AddToRecentFiles:= _
        True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:= _
        False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
        SaveAsAOCELetter:=False
    End With
    
    ActiveSheet.DrawingObjects.Copy
    objWord.Selection.Paste
    
    Set objWord = Nothing
End Sub

Abraço

 
Postado : 14/09/2011 6:54 am
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Ficou otimo.

Obrigado mais uma vez!.

Abraço.

 
Postado : 16/09/2011 10:17 am
Forum Jump:
  Tópico Anterior
Próximo Tópico