EXCEL CON VISUAL BASIC 0

SI ANIDADO

=SI(A3<10;"MENOR 10";SI(A3>=80;"MAYORIGUAL 80";"ENTRE 10 Y 80"))

Borre las notas que estan en rango c6:d16, luego de una previa confirmacion

Dim rpt as integer rpt = msgbox("seguro de borrar notas?", vbYesNo+VbQuestion, "Confirmar") If rpt = vbYes then range("c6:d16").clearcontents else msgbox "operacion cancelada",vbInformation, "Confirmar" End if

Copie el valor de una celda a un rango de celdas

Private Sub CommandButton1_Click() Range("e5").Copy Range("b8:b17").PasteSpecial xlPasteValues Application.CutCopyMode = False End Sub

pegado de valores en la columna A NORMAL REFINANCIADO LEASEBACK VENCIDOS 91 DIAS VENCIDOS 31 DIAS A 90 DIAS CONTRATOS RESUELTOS VENCIDOS CONTRATOS JUDICIALES

Private Sub CommandButton1_Click() Range("a3").Copy Range("a4:a819").PasteSpecial xlPasteValues Application.CutCopyMode = False Range("a820").Copy Range("a821:a833").PasteSpecial xlPasteValues Application.CutCopyMode = False Range("a834").Copy Range("a835:a879").PasteSpecial xlPasteValues Application.CutCopyMode = False Range("a880").Copy Range("a881:a902").PasteSpecial xlPasteValues Application.CutCopyMode = False Range("a903").Copy Range("a904:a1042").PasteSpecial xlPasteValues Application.CutCopyMode = False Range("a1043").Copy Range("a1044:a1075").PasteSpecial xlPasteValues Application.CutCopyMode = False End Sub

funcion que devuelve el numero de fila del valor buscado

Function FilaDelValor(Rng As Range, ValorBuscado As String) As Single 'devuelve la fila en la que se encuentra un valor Dim fila As Single Dim busco As Object Set busco = Rng.Find(ValorBuscado) FilaDelValor = busco.Row End Function

Eliminar filas según su contenido

Sub BORRAR() 'Primero hacemos una copia completa de la hoja Dim HojaActual As String HojaActual = ActiveSheet.Name 'MsgBox HojaActual Sheets(HojaActual).Select Sheets(HojaActual).Copy Before:=Sheets(1) '-------------------------------------------------- 'Despues eliminamos las filas cuya columna G tenga contenido Dim i As Integer, nfilas As Integer nfilas = ActiveSheet.Cells(1, 1).CurrentRegion.Rows.Count qCol = InputBox("Columna del criterio") qCrit = InputBox("Criterio") For i = nfilas To 1 Step -1 Cells(i, qCol).Select If Cells(i, qCol) = qCrit Then ActiveCell.EntireRow.Select Selection.Delete End If Next i End Sub

BORRAR FILAS DE CREDITOS ' PERO FALTA ELIMINAR LAS PRIMERAS FILAS

Sub BORRAR() 'Primero hacemos una copia completa de la hoja Dim HojaActual As String HojaActual = ActiveSheet.Name 'MsgBox HojaActual Sheets(HojaActual).Select Sheets(HojaActual).Copy Before:=Sheets(1) '-------------------------------------------------- 'Despues eliminamos las filas cuya columna G tenga contenido Dim i As Integer, nfilas As Integer nfilas = ActiveSheet.Cells(1, 1).CurrentRegion.Rows.Count 'qCol = InputBox("Columna del criterio") 'qCrit = InputBox("Criterio") For i = nfilas To 1 Step -1 Cells(i, 1).Select 'If Cells(i, qCol) = qCrit Then If Cells(i, 1) = "CREDITOS A GRANDES EMPRESAS" Or Cells(i, 1) = "CREDITOS A MEDIANAS EMPRESAS" Or Cells(i, 1) = "CREDITOS A PEQUEÑAS EMPRESAS" Or Cells(i, 1) = "CREDITOS A MICROEMPRESAS" Then ActiveCell.EntireRow.Select Selection.Delete End If Next i For i = nfilas To 1 Step -1 Cells(i, 3).Select 'If Cells(i, qCol) = qCrit Then If Cells(i, 3) = "TOTAL" Then ActiveCell.EntireRow.Select Selection.Delete End If Next i End Sub

BORRAR_COLUMNA

Sub BORRAR_COLUMNA() Dim participantes As Range Dim CONTADOR As Long Set participantes = ActiveSheet.UsedRange For CONTADOR = participantes.Columns.Count To 1 Step -1 If Application.CountA(Columns(CONTADOR).EntireColumn) = 0 Then Columns(CONTADOR).Delete End If Next CONTADOR End Sub

Copiar datos de una hoja a otra

Sub CopiarCeldas() 'Definir objetos a utilizar Dim wsOrigen As Excel.Worksheet, _ wsDestino As Excel.Worksheet, _ rngOrigen As Excel.Range, _ rngDestino As Excel.Range 'Indicar las hojas de origen y destino Set wsOrigen = Worksheets("Sol") Set wsDestino = Worksheets("Consolid_Jun2016") 'Indicar la celda de origen y destino Const celdaOrigen = "A1" Const celdaDestino = "A1105" 'Inicializar los rangos de origen y destino Set rngOrigen = wsOrigen.Range(celdaOrigen) Set rngDestino = wsDestino.Range(celdaDestino) 'Seleccionar rango de celdas origen rngOrigen.Select Range(Selection, Selection.End(xlDown)).Select Range(Selection, Selection.End(xlToRight)).Select Selection.Copy 'Pegar datos en celda destino rngDestino.PasteSpecial xlPasteValues Application.CutCopyMode = False End Sub

Macro para copiar y pegar celdas en Excel que cumplan la condicion http://excelyvba.com/macro-para-copiar-y-pegar-celdas-en-excel/

Sub Copiar_Filas() 'inicializo la variable j j = 2 'comienzo el bucle For i = 2 To 101 'activo la hoja donde están mis datos Sheets("Datos").Activate 'compruebo que el valor de la fecha es mayor que 30 If Cells(i, "B").Value > 30 Then 'copio la fila entera Range(Cells(i, "A"), Cells(i, "D")).Copy 'selecciono la hoja donde quiero pegar y después la celda Sheets("Filtro").Activate Cells(j, "A").Select 'pego la fila que hemos copiado ActiveSheet.Paste 'aumento la variable j para que vaya a la siguiente fila de la hoja filtros 'cuando encuentre una nueva fila que cumple con la condición de edad j = j + 1 End If Next End Sub

https://www.extendoffice.com/documents/excel/3489-excel-split-list-into-groups.html#a1

Sub SplitIntoCellsPerColumn() 'updateby Extendoffice Dim xRg As Range Dim xOutRg As Range Dim xCell As Range Dim xTxt As String Dim xOutArr As Variant Dim I As Long, K As Long On Error Resume Next xTxt = ActiveWindow.RangeSelection.Address Sel: Set xRg = Nothing Set xRg = Application.InputBox("please select data range:", "Kutools for Excel", xTxt, , , , , 8) If xRg Is Nothing Then Exit Sub If xRg.Areas.Count > 1 Then MsgBox "does not support multiple selections, please select again", vbInformation, "Kutools for Excel" GoTo Sel End If If xRg.Columns.Count > 1 Then MsgBox "does not support multiple columns,please select again", vbInformation, "Kutools for Excel" GoTo Sel End If Set xOutRg = Application.InputBox("please select a cell to put the result:", "Kutools for Excel", , , , , , 8) If xOutRg Is Nothing Then Exit Sub I = Application.InputBox("the number of cell per column:", "Kutools for Excel", , , , , , 1) If I < 1 Then MsgBox "incorrect enter", vbInformation, "Kutools for Excel" Exit Sub End If ReDim xOutArr(1 To I, 1 To Int(xRg.Rows.Count / I) + 1) For K = 0 To xRg.Rows.Count - 1 xOutArr(1 + (K Mod I), 1 + Int(K / I)) = xRg.Cells(K + 1) Next xOutRg.Range("A1").Resize(I, UBound(xOutArr, 2)) = xOutArr End Sub

Split a long list into multiple equal groups with VBA code-https://www.extendoffice.com/no/documents/excel/3489-excel-split#a1

Sub SplitIntoCellsPerColumn() 'updatebyExtendoffice 20160225 Dim xRg As Range Dim xOutRg As Range Dim xCell As Range Dim xTxt As String Dim xOutArr As Variant Dim I As Long, K As Long On Error Resume Next xTxt = ActiveWindow.RangeSelection.Address Sel: Set xRg = Nothing Set xRg = Application.InputBox("please select data range:", "Kutools for Excel", xTxt, , , , , 8) If xRg Is Nothing Then Exit Sub If xRg.Areas.Count > 1 Then MsgBox "does not support multiple selections, please select again", vbInformation, "Kutools for Excel" GoTo Sel End If If xRg.Columns.Count > 1 Then MsgBox "does not support multiple columns,please select again", vbInformation, "Kutools for Excel" GoTo Sel End If Set xOutRg = Application.InputBox("please select a cell to put the result:", "Kutools for Excel", , , , , , 8) If xOutRg Is Nothing Then Exit Sub I = Application.InputBox("the number of cell per column:", "Kutools for Excel", , , , , , 1) If I < 1 Then MsgBox "incorrect enter", vbInformation, "Kutools for Excel" Exit Sub End If ReDim xOutArr(1 To I, 1 To Int(xRg.Rows.Count / I) + 1) For K = 0 To xRg.Rows.Count - 1 xOutArr(1 + (K Mod I), 1 + Int(K / I)) = xRg.Cells(K + 1) Next xOutRg.Range("A1").Resize(I, UBound(xOutArr, 2)) = xOutArr End Sub

para buscar un valor y borrar el contenido

Sub buscaryborrar() Dim Borrar As Boolean Borrar = False valor_buscado = InputBox("Introduzca el valor a buscar y borrar", "Valor a buscar") On Local Error Resume Next If valor_buscado <> "" Then Do While Err.Number = 0 Columns("A:Z").Select Selection.Find(What:=valor_buscado, After:=ActiveCell, LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False).Activate If Err.Number = 0 Then ActiveCell.Select Selection.ClearContents Borrar = True End If Loop Range("A1").Select If Borrado = True Then MsgBox "Valores encontrados y borrados", vbInformation, "Borrados" Else MsgBox "Valor no encontrado.", vbExclamation, "No encontrado" End If Else MsgBox ("Valor no válido") End If End Sub

eliminar filas en blanco

Sub eliminarfilavacia() For fila = 1 To 6000 If Cells(fila, 4).Value = "" Then Rows(fila).Delete End If Next fila End Sub ' The following code deletes blank rows from the active worksheet. Sub DelRow() Dim Counter Dim i As Integer ' Input box to determine the total number of rows in the worksheet. Counter = InputBox("Enter the total number of rows to process") ActiveCell.Select ' Loops through the desired number of rows. For i = 1 To Counter ' Checks to see if the active cell is blank. If ActiveCell = "" Then Selection.EntireRow.Delete ' Decrements count each time a row is deleted. This ensures ' that the macro will not run past the last row. Counter = Counter - 1 Else ' Selects the next cell. ActiveCell.Offset(1, 0).Select End If Next i End Sub

pegar en la fila de abajo

Sub hola() ActiveCell.Select Selection.Copy Selection.Offset(1, 0).PasteSpecial xlPasteAll End Sub

Emplear un boton de comando que borre las datos celdas "C3", "C5" , "C7" luego de una previa confirmación

if msgbox("seguro de borrar?",vbYesNo+vbQuestion,"confirmar")=vbYes then range("c3").select selection.clearcontents range("c5").select selection.clearcontents range("c7").select selection.clearcontents else msgbox "Accion cancelada!",vbOKOnly+vbExclamation, "Aviso" End If