Macro buscar texto expecifico y copiar según condición
Estoy trabajando en un archivo que necesito una macro y no llego a solucionarlo, solicito en la medida de lo posible vuestra colaboración la macro que necesito es la siguiente:
Tengo una hoja llamada "PRESUPUESTO FINAL" y en la columna B a partir de la fila 7 una serie de textos -Capítulo, Partida, y quiero que valla recoriendo la columna hasta que encuentre alguna palabra especifica (Capítulo, Partida) y según la palabra que encuentre se valla a la hoja llamada "MODULO INSERCIÓN1" si encuentra "Capítulo" el rango a copiar es H4:EG4, y lo pega en la misma fila que encontro la palabra apartir de la columna H de LA HOJA "PRESUPUESTO FINAL" y asi sucesivamente, si encuentra la palabra "Partida" el rango a copiar de la hoja llamada "MODULO INSERCIÓN1" es H7:EG4 y lo pega en la misma fila que encontro la palabra apartir de la columna H de la hoja "PRESUPUESTO FINAL" y si al recorrer la columna "B" se encuentra una celda en blanco el rango a copiar de la joha llamada "MODULO INSERCIÓN1" es H9:EG9, he intentado hacer algo pero no tengo el suficiente conocimiento.
Sub Copiar_Rango_Capitulo()
Application.ScreenUpdating = False
'selecciona rango b2
Sheets("PRESUPUESTO FINAL").Select
Range("B7").Select
'inicia bucle hasta que se encuentre una celda en blanco
Do While ActiveCell <> ""
'condición en la que decimos que si se encuentra el nombre oscar copie
'desde esa celda hasta las 5 columnas siguientes
If ActiveCell = "Capítulo" Then
Sheets("MODULO INSERCIÓN1").Select
Range("H4").Select
ActiveCell.Select
Range(ActiveCell, ActiveCell.Offset(0, 130)).Select
Selection.Copy
Sheets("PRESUPUESTO FINAL").Select
'countult = Cells(Rows.Count, 8).End(xlUp).Offset(1, 0).RowHeight = 20.25
'MsgBox countult
'Cells(Rows.Count, 8).End(xlUp).Offset(1, 0).Select
Range("h7").Select
'inicia otro bucle para encontrar una celda en blanco para pergar el contenido copiado anteriormente
Do While ActiveCell <> ""
ActiveCell.Offset(1, 0).Select
Loop
ActiveSheet.Paste
End If
Sheets("PRESUPUESTO FINAL").Select
ActiveCell.Offset(1, 0).Select
Loop
End Sub
1 respuesta
H o l a:
Te anexo la macro
Sub CopiarCapitulo()
'Por.Dante Amor
Set h1 = Sheets("PRESUPUESTO FINAL")
Set h2 = Sheets("MODULO INSERCIÓN1")
'
For i = 7 To h1.Range("B" & Rows.Count).End(xlUp).Row
Select Case h1.Cells(i, "B")
Case "Capítulo": h2.Range("H4:EG4").Copy h1.Cells(i, "H")
Case "Partida": h2.Range("H7:EG7").Copy h1.Cells(i, "H")
Case "": h2.Range("H9:EG9").Copy h1.Cells(i, "H")
End Select
Next
MsgBox "Fin"
End Sub' : ) 'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias ' : )
