Anónimo
Macro para insertar renglones con forumulas
Tengo la siguiente macro para insertar renglones copiando formatos, formulas y lista de valores. Funciona perfectamente yo me puedo ubicar entre dos renglones con información y fotos e inserta el numero de renglones que yo le indico pero me copia la foto y no quiero que se copia la foto que estaba en el renglón donde me ubico para insertar el renglón
Les agradezco su ayuda para poder solucionar esta situación:
Quiero que se inserte el renglón copiando las formulas, formatos y lista de valores pero no las fotos del renglón inmediato anterior (cuando existen)
Adjunto la macro
Sub Macro2()
'
' Macro2 Macro
'Sub InsertRowsAndFillFormulas_caller()
'-- this macro shows on Tools, Macro..., Macros (Alt+F8) dialog
If Selection.Row > 9 And Selection.Row < 58 Then
ThisWorkbook.Sheets("RIIA - Relación de Desperfectos").Unprotect Range("BM3").Text
Call InsertRowsAndFillFormulas
ThisWorkbook.Sheets("RIIA - Relación de Desperfectos").Protect Range("BM3").Text, DrawingObjects:=False, Contents:=True, Scenarios:= _
False, AllowInsertingHyperlinks:=True, AllowSorting:=True, AllowFiltering:=True
End If
End Sub
Sub InsertRowsAndFillFormulas(Optional vRows As Long = 0)
' Documented: http://www.mvps.org/dmcritchie/excel/insrtrow.htm
' Re: Insert Rows -- 1997/09/24 Mark Hill
' row selection based on active cell -- rev. 2000-09-02 David McRitchie
Dim x As Long
ActiveCell.EntireRow.Select 'So you do not have to preselect entire row
If vRows = 0 Then
vRows = Application.InputBox(prompt:= _
"Cuantas filas quiere insertar?, el cursor debe estar colocado en la fila superior a partir de la cual quiere insertar las filas, si es correcto presione ACEPTAR, de lo contrario, presione CANCELAR", Title:="Add Rows", _
Default:=1, Type:=1) 'Default for 1 row, type 1 is number
If vRows = False Then Exit Sub
End If
'if you just want to add cells and not entire rows
'then delete ".EntireRow" in the following line
'rev. 2001-01-17 Gary L. Brown, programming, Grouped sheets
Dim sht As Worksheet, shts() As String, i As Long
ReDim shts(1 To Worksheets.Application.ActiveWorkbook. _
Windows(1).SelectedSheets.Count)
i = 0
For Each sht In _
Application.ActiveWorkbook.Windows(1).SelectedSheets
Sheets(sht.Name).Select
i = i + 1
shts(i) = sht.Name
x = Sheets(sht.Name).UsedRange.Rows.Count 'lastcell fixup
Selection.Resize(rowsize:=2).Rows(2).EntireRow. _
Resize(rowsize:=vRows).Insert Shift:=xlDown
Selection.AutoFill Selection.Resize( _
rowsize:=vRows + 1), xlFillDefault
On Error Resume Next 'to handle no constants in range -- John McKee 2000/02/01
' to remove the non-formulas -- 1998/03/11 Bill Manville
Selection.Offset(1).Resize(vRows).EntireRow. _
SpecialCells(xlConstants).ClearContents
Next sht
Worksheets(shts).Select
End Sub
Les agradezco su ayuda para poder solucionar esta situación:
Quiero que se inserte el renglón copiando las formulas, formatos y lista de valores pero no las fotos del renglón inmediato anterior (cuando existen)
Adjunto la macro
Sub Macro2()
'
' Macro2 Macro
'Sub InsertRowsAndFillFormulas_caller()
'-- this macro shows on Tools, Macro..., Macros (Alt+F8) dialog
If Selection.Row > 9 And Selection.Row < 58 Then
ThisWorkbook.Sheets("RIIA - Relación de Desperfectos").Unprotect Range("BM3").Text
Call InsertRowsAndFillFormulas
ThisWorkbook.Sheets("RIIA - Relación de Desperfectos").Protect Range("BM3").Text, DrawingObjects:=False, Contents:=True, Scenarios:= _
False, AllowInsertingHyperlinks:=True, AllowSorting:=True, AllowFiltering:=True
End If
End Sub
Sub InsertRowsAndFillFormulas(Optional vRows As Long = 0)
' Documented: http://www.mvps.org/dmcritchie/excel/insrtrow.htm
' Re: Insert Rows -- 1997/09/24 Mark Hill
' row selection based on active cell -- rev. 2000-09-02 David McRitchie
Dim x As Long
ActiveCell.EntireRow.Select 'So you do not have to preselect entire row
If vRows = 0 Then
vRows = Application.InputBox(prompt:= _
"Cuantas filas quiere insertar?, el cursor debe estar colocado en la fila superior a partir de la cual quiere insertar las filas, si es correcto presione ACEPTAR, de lo contrario, presione CANCELAR", Title:="Add Rows", _
Default:=1, Type:=1) 'Default for 1 row, type 1 is number
If vRows = False Then Exit Sub
End If
'if you just want to add cells and not entire rows
'then delete ".EntireRow" in the following line
'rev. 2001-01-17 Gary L. Brown, programming, Grouped sheets
Dim sht As Worksheet, shts() As String, i As Long
ReDim shts(1 To Worksheets.Application.ActiveWorkbook. _
Windows(1).SelectedSheets.Count)
i = 0
For Each sht In _
Application.ActiveWorkbook.Windows(1).SelectedSheets
Sheets(sht.Name).Select
i = i + 1
shts(i) = sht.Name
x = Sheets(sht.Name).UsedRange.Rows.Count 'lastcell fixup
Selection.Resize(rowsize:=2).Rows(2).EntireRow. _
Resize(rowsize:=vRows).Insert Shift:=xlDown
Selection.AutoFill Selection.Resize( _
rowsize:=vRows + 1), xlFillDefault
On Error Resume Next 'to handle no constants in range -- John McKee 2000/02/01
' to remove the non-formulas -- 1998/03/11 Bill Manville
Selection.Offset(1).Resize(vRows).EntireRow. _
SpecialCells(xlConstants).ClearContents
Next sht
Worksheets(shts).Select
End Sub