Word a excel
Hola josaul75.
Tengo una consulta de como realizar una macro en word para que me lleve todos los títulos 1 y títulos 2 me los lleve en distintas celdas de excel (B15-C15), ambos títulos en diferente celdas insertándose hacia abajo correlativamente.
Si me puedes ayudar... Gracias.
Tengo una consulta de como realizar una macro en word para que me lleve todos los títulos 1 y títulos 2 me los lleve en distintas celdas de excel (B15-C15), ambos títulos en diferente celdas insertándose hacia abajo correlativamente.
Si me puedes ayudar... Gracias.
1 respuesta
Respuesta de José Saúl Méndez Alonso
1
1
Te dejo este código a ver si te sirve
Sub Macro1()
Dim ExcelApp As Object
Dim nParrafo As Integer
Dim sParrafo As Paragraph
Dim sRutaExcel As String
Dim sCelda As String
sRutaExcel = "C:\MiExcel.xls"
Set ExcelApp = CreateObject("Excel.Application")
ExcelApp.Visible = True
' Estas líneas son opcionales solo por si quieres que se cree el archivo
' ExcelApp.Workbooks.Add
' ExcelApp.ActiveWorkbook.SaveAs FileName:="C:\MiExcel.xls", FileFormat:=xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
ExcelApp.Workbooks.Open FileName:=sRutaExcel
ExcelApp.Worksheets("Hoja1").Select
nParrafo = 15
For Each sParrafo In ActiveDocument.Paragraphs
If sParrafo.OutlineLevel = wdOutlineLevel1 Then
ExcelApp.Range("B" & nParrafo).Value = Trim(Replace(Replace(sParrafo.Range.Text, Chr(13), ""), Chr(12), ""))
nParrafo = nParrafo + 1
End If
If sParrafo.OutlineLevel = wdOutlineLevel2 Then
ExcelApp.Range("C" & nParrafo).Value = Trim(Replace(Replace(sParrafo.Range.Text, Chr(13), ""), Chr(12), ""))
nParrafo = nParrafo + 1
End If
Next
End Sub
Sub Macro1()
Dim ExcelApp As Object
Dim nParrafo As Integer
Dim sParrafo As Paragraph
Dim sRutaExcel As String
Dim sCelda As String
sRutaExcel = "C:\MiExcel.xls"
Set ExcelApp = CreateObject("Excel.Application")
ExcelApp.Visible = True
' Estas líneas son opcionales solo por si quieres que se cree el archivo
' ExcelApp.Workbooks.Add
' ExcelApp.ActiveWorkbook.SaveAs FileName:="C:\MiExcel.xls", FileFormat:=xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
ExcelApp.Workbooks.Open FileName:=sRutaExcel
ExcelApp.Worksheets("Hoja1").Select
nParrafo = 15
For Each sParrafo In ActiveDocument.Paragraphs
If sParrafo.OutlineLevel = wdOutlineLevel1 Then
ExcelApp.Range("B" & nParrafo).Value = Trim(Replace(Replace(sParrafo.Range.Text, Chr(13), ""), Chr(12), ""))
nParrafo = nParrafo + 1
End If
If sParrafo.OutlineLevel = wdOutlineLevel2 Then
ExcelApp.Range("C" & nParrafo).Value = Trim(Replace(Replace(sParrafo.Range.Text, Chr(13), ""), Chr(12), ""))
nParrafo = nParrafo + 1
End If
Next
End Sub
Hola, gracias por el tiempo que me dedicas. Tu código me sirvió muy bien.
Ahora que tengo los 2 códigos que me creaste que fueron el (Insertar comentarios y Insertar los titulos1 y títulos 2) todos estos en una hoja excel.
Pero lo que quiero logra es ordena esto ya que el titulo1, titulo2 y los comentario se me desordena al momento de ejecutar la macro.
La idea es la siguiente:
Lo quiero es que me pegue en la hoja excel el titulo 1, titulo2 y lo comentarios que corresponde a ese titulo, y haci sucesivamente. Osea cada titulo2 este con todos sus comentarios que corresponda al momento de ejecutar la macro y enviarlo al excel.
Acá te adjunto los códigos que me enviaste..
Sub Macro1()
Dim ExcelApp As Object
Dim nComentario As Integer
Dim sComentario As Comment
Dim sRutaExcel As String
Dim sCelda As String
Dim nParrafo As Integer
Dim sParrafo As Paragraph
sRutaExcel = "C:\MiExcel.xls"
Set ExcelApp = CreateObject("Excel.Application")
ExcelApp.Visible = True
ExcelApp.Workbooks.Open FileName:=sRutaExcel
ExcelApp.Worksheets("Hoja1").Select
nComentario = 15
For Each sComentario In ActiveDocument.Comments
ExcelApp.Range("E" & nComentario).Value = sComentario.Range.Text
ExcelApp.Range("D" & nComentario).Value = sComentario.Index
nComentario = nComentario + 1
Next
nParrafo = 15
For Each sParrafo In ActiveDocument.Paragraphs
If sParrafo.OutlineLevel = wdOutlineLevel1 Then
ExcelApp.Range("B" & nParrafo).Value = Trim(Replace(Replace(sParrafo.Range.Text, Chr(13), ""), Chr(12), ""))
nParrafo = nParrafo + 1
End If
If sParrafo.OutlineLevel = wdOutlineLevel2 Then
ExcelApp.Range("C" & nParrafo).Value = Trim(Replace(Replace(sParrafo.Range.Text, Chr(13), ""), Chr(12), ""))
nParrafo = nParrafo + 1
End If
Next
End Sub
' De esta maneta me funciona bien, pero me pega los titulos1 y titulos 2 desordenados con los comentarios, los titulos no queda con sus comentarios correspondientes
Si me pudieras ayudar
De antemano muchas gracias
Ahora que tengo los 2 códigos que me creaste que fueron el (Insertar comentarios y Insertar los titulos1 y títulos 2) todos estos en una hoja excel.
Pero lo que quiero logra es ordena esto ya que el titulo1, titulo2 y los comentario se me desordena al momento de ejecutar la macro.
La idea es la siguiente:
Lo quiero es que me pegue en la hoja excel el titulo 1, titulo2 y lo comentarios que corresponde a ese titulo, y haci sucesivamente. Osea cada titulo2 este con todos sus comentarios que corresponda al momento de ejecutar la macro y enviarlo al excel.
Acá te adjunto los códigos que me enviaste..
Sub Macro1()
Dim ExcelApp As Object
Dim nComentario As Integer
Dim sComentario As Comment
Dim sRutaExcel As String
Dim sCelda As String
Dim nParrafo As Integer
Dim sParrafo As Paragraph
sRutaExcel = "C:\MiExcel.xls"
Set ExcelApp = CreateObject("Excel.Application")
ExcelApp.Visible = True
ExcelApp.Workbooks.Open FileName:=sRutaExcel
ExcelApp.Worksheets("Hoja1").Select
nComentario = 15
For Each sComentario In ActiveDocument.Comments
ExcelApp.Range("E" & nComentario).Value = sComentario.Range.Text
ExcelApp.Range("D" & nComentario).Value = sComentario.Index
nComentario = nComentario + 1
Next
nParrafo = 15
For Each sParrafo In ActiveDocument.Paragraphs
If sParrafo.OutlineLevel = wdOutlineLevel1 Then
ExcelApp.Range("B" & nParrafo).Value = Trim(Replace(Replace(sParrafo.Range.Text, Chr(13), ""), Chr(12), ""))
nParrafo = nParrafo + 1
End If
If sParrafo.OutlineLevel = wdOutlineLevel2 Then
ExcelApp.Range("C" & nParrafo).Value = Trim(Replace(Replace(sParrafo.Range.Text, Chr(13), ""), Chr(12), ""))
nParrafo = nParrafo + 1
End If
Next
End Sub
' De esta maneta me funciona bien, pero me pega los titulos1 y titulos 2 desordenados con los comentarios, los titulos no queda con sus comentarios correspondientes
Si me pudieras ayudar
De antemano muchas gracias
Que te parece si me mandas una copia de tu documento para hacerte una MACRO de acuerdo a lo que necesitas, mi correo es [email protected]
Hola.
La verdad quiero ver si me puedes ayudar con una macro en word... lo que quiero realizar en esta macro es que me lleve los comentarios de word a excel, lo cual ya lo tengo hecho, pero en la descripción del comentario tengo palabras que están entre paréntesis "Eso también lo quiero llevar a una celda en excel", pero no se como seleccionar algo especifico. Por ejemplo:
Dentro del comentario tengo por ejemplo esto:
comentario [x]: bla la bla bla (bla bla) bla bla.
Ojala te sirva el ejemplo, eso es lo quiero llevar lo que esta entre paréntesis a una celda en excel, ya que el detalle y el numero del comentario ya se como llevarlo a excel en distintas celdas.
Gracias
La verdad quiero ver si me puedes ayudar con una macro en word... lo que quiero realizar en esta macro es que me lleve los comentarios de word a excel, lo cual ya lo tengo hecho, pero en la descripción del comentario tengo palabras que están entre paréntesis "Eso también lo quiero llevar a una celda en excel", pero no se como seleccionar algo especifico. Por ejemplo:
Dentro del comentario tengo por ejemplo esto:
comentario [x]: bla la bla bla (bla bla) bla bla.
Ojala te sirva el ejemplo, eso es lo quiero llevar lo que esta entre paréntesis a una celda en excel, ya que el detalle y el numero del comentario ya se como llevarlo a excel en distintas celdas.
Gracias
Hice unos cambios para que veas como extraer parte del texto, espero te sea de utilidad
Sub Macro2()
Dim ExcelApp As Object
Dim nComentario As Integer
Dim sComentario As Comment
Dim sRutaExcel As String
Dim sCelda As String
Dim nParrafo As Integer
Dim sParrafo As Paragraph
Dim sTextoEspecial As String
Dim nPosIni As Integer
Dim nPosFin As Integer
sRutaExcel = "C:\MiExcel.xls"
Set ExcelApp = CreateObject("Excel.Application")
ExcelApp.Visible = True
ExcelApp.Workbooks.Open FileName:=sRutaExcel
ExcelApp.Worksheets("Hoja1").Select
nComentario = 15
For Each sComentario In ActiveDocument.Comments
nPosIni = InStr(1, sComentario.Range.Text, "(")
nPosFin = InStr(1, sComentario.Range.Text, ")")
If nPosIni > 0 And nPosFin Then
sTextoEspecial = Mid(sComentario.Range.Text, nPosIni, nPosFin - nposni)
ExcelApp.Range("M" & nComentario).Value = sTextoEspecial
End If
ExcelApp.Range("E" & nComentario).Value = sComentario.Range.Text
ExcelApp.Range("D" & nComentario).Value = sComentario.Index
nComentario = nComentario + 1
Next
nParrafo = 15
For Each sParrafo In ActiveDocument.Paragraphs
If sParrafo.OutlineLevel = wdOutlineLevel1 Then
ExcelApp.Range("B" & nParrafo).Value = Trim(Replace(Replace(sParrafo.Range.Text, Chr(13), ""), Chr(12), ""))
nParrafo = nParrafo + 1
End If
If sParrafo.OutlineLevel = wdOutlineLevel2 Then
ExcelApp.Range("C" & nParrafo).Value = Trim(Replace(Replace(sParrafo.Range.Text, Chr(13), ""), Chr(12), ""))
nParrafo = nParrafo + 1
End If
Next
End Sub
Sub Macro2()
Dim ExcelApp As Object
Dim nComentario As Integer
Dim sComentario As Comment
Dim sRutaExcel As String
Dim sCelda As String
Dim nParrafo As Integer
Dim sParrafo As Paragraph
Dim sTextoEspecial As String
Dim nPosIni As Integer
Dim nPosFin As Integer
sRutaExcel = "C:\MiExcel.xls"
Set ExcelApp = CreateObject("Excel.Application")
ExcelApp.Visible = True
ExcelApp.Workbooks.Open FileName:=sRutaExcel
ExcelApp.Worksheets("Hoja1").Select
nComentario = 15
For Each sComentario In ActiveDocument.Comments
nPosIni = InStr(1, sComentario.Range.Text, "(")
nPosFin = InStr(1, sComentario.Range.Text, ")")
If nPosIni > 0 And nPosFin Then
sTextoEspecial = Mid(sComentario.Range.Text, nPosIni, nPosFin - nposni)
ExcelApp.Range("M" & nComentario).Value = sTextoEspecial
End If
ExcelApp.Range("E" & nComentario).Value = sComentario.Range.Text
ExcelApp.Range("D" & nComentario).Value = sComentario.Index
nComentario = nComentario + 1
Next
nParrafo = 15
For Each sParrafo In ActiveDocument.Paragraphs
If sParrafo.OutlineLevel = wdOutlineLevel1 Then
ExcelApp.Range("B" & nParrafo).Value = Trim(Replace(Replace(sParrafo.Range.Text, Chr(13), ""), Chr(12), ""))
nParrafo = nParrafo + 1
End If
If sParrafo.OutlineLevel = wdOutlineLevel2 Then
ExcelApp.Range("C" & nParrafo).Value = Trim(Replace(Replace(sParrafo.Range.Text, Chr(13), ""), Chr(12), ""))
nParrafo = nParrafo + 1
End If
Next
End Sub
- Compartir respuesta
- Anónimo
ahora mismo