CODIGOS ABREVIADOS EXCEL Y OFFICE EN GENERAL

Click aqui

Salsa Chichoky

cancion mp3 Salsa Chichoky

ANCHO COLUMNA SEGUN VALOR CELDA

este codigo lo que hace es definir el ancho de la celda por el valor que contenga una celda.




code:

'hacer esto hasta que la celda activa de arriba sea vacia
Do Until ActiveCell.Offset(-1, 0).Value = ""
' para la seleccion de celda ancho= al valor de la celda de arriba
Selection.ColumnWidth = ActiveCell.Offset(-1, 0).Value
' desplazar a la derecha
ActiveCell.Offset(0, 1).Select

'repitis
Loop

Ejecutar un macro al cambiar una celda

Private Sub Worksheet_Change(ByVal Target As Range)
'pasamos a una variable, la celda o celdas
'que queremos evaluar si cambian o no
datos1 = "B5"
datos2 = "B7"
datos3 = "B12"
'como estamos dentro del evento "Change", algo tiene
'que estar cambiando... Pues bien, si la celda activa
'es la misma que la celda que hemos puesto en
'la variable llamada "datos", entonces
'que muestre un mensaje (recordemos que una doble
'negación es una afirmación)
If Not Application.Intersect(Target, Range(datos1)) Is Nothing Or _
Not Application.Intersect(Target, Range(datos2)) Is Nothing Or _
Not Application.Intersect(Target, Range(datos3)) Is Nothing Then
'mostramos un mensaje
MsgBox ("Oyeeeee, sé que estás cambiando alguna de estas celdas " & _
datos1 & ", " & datos2 & ", " & datos3 & ".")
End If
End Sub



Fuente

EVITAR DEJAR UNA CELDA EN BLANCO

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Target.Row = 1 Then Exit Sub
If Selection.Cells.Count > 1 Then Exit Sub
Application.EnableEvents = False
With Me.Range("A1")
.Value = .Value
End With
On Error GoTo Finish
If Not Target.Row = 1 Then
With Me.Range("A" & Target.Row).SpecialCells(xlCellTypeBlanks)
MsgBox "The range " & .Address(0, 0) & " is still blank"
.Select
End With
End If
Finish:
Application.EnableEvents = True
End Sub

CREAR LISTA DE HOJAS EN UNA NUEVA

Sub ListSheetNames()

Dim NumSheets
NumSheets = Sheets.Count

Application.DisplayAlerts = False
Dim i
For i = 1 To NumSheets + 1
If ActiveSheet.Name = "SheetNames" Then
Sheets("SheetNames").Select
ActiveWindow.SelectedSheets.Delete
Exit Sub
End If
Next i
Application.DisplayAlerts = True

Sheets.Add
ActiveSheet.Name = "SheetNames"
Sheets("SheetNames").Move after:=Sheets(NumSheets + 1)
'MsgBox (NumSheets)



For i = 1 To NumSheets
Range("A" & i) = Sheets(i).Name
Next i

End Sub

Filtrar por rango de fechas en una tabla dinámica

Filtrar por rango de fechas en una tabla dinámica
La siguiente macro de evento permitirá filtrar entre un rango de fechas en el filtro de informe de una tabla dinámica, lo que evitará tener que seleccionar de manera manual las fechas correspondientes al rango que se desea filtrar.

Para ello, haremos uso de dos celdas complementarias en las cuales indicaremos la fecha inicial y la fecha final del rango entre el cual queremos filtrar.

En el archivo de ejemplo he usado la celda B2 para ingresar la celda inicial y la celda B3 para ingresar la fecha final que indicarán las fechas a filtrar en el filtro de informe llamado "Fecha" : Archivo de descarga

Private Sub Worksheet_Change(ByVal Target As Excel.Range)

Dim Fecha_i As Date
Dim Fecha_f As Date
Dim Fecha As Date
Dim pi As PivotItem

If Not Application.Intersect(Target, Me.Range("b2:b3")) Is Nothing Then

If Me.Range("b3") <= Me.Range("b2") Then

With Application
.EnableEvents = False
.Undo
.EnableEvents = True
End With

MsgBox prompt:="La fecha de inicio debe ser menor a la fecha final.", title:="Filtro fechas"

Else

On Error Resume Next

Fecha_i = Me.Range("b2")
Fecha_f = Me.Range("b3")

Application.ScreenUpdating = False

With ActiveSheet.PivotTables(1).PivotFields("Fecha")
.EnableMultiplePageItems = True
Application.EnableEvents = False
For Each pi In .PivotItems
pi.Visible = True
Fecha = VBA.Format(pi.Value, "mm-dd-yy")
If Fecha < Fecha_i Or Fecha > Fecha_f Then
pi.Visible = False
End If
Next pi
Application.EnableEvents = True
End With

Application.ScreenUpdating = True

End If

End If

End Sub



Fuente: Excelpatas

Aca creas una barra en complementos pero tienes que guardarla como complementos. xla

Sub crear_barra()
Dim Boton As CommandBarButton

CommandBars.Add(Name:="aux").Visible = True
Set Boton = CommandBars("aux").Controls.Add(Type:=msoControlButton)
With Boton
.Caption = "Balances APTS"
.FaceId = 6772
.OnAction = "Balances_Fecha_Corte"

End With


CommandBars.Add(Name:="Awen").Visible = True
Set Boton = CommandBars("Awen").Controls.Add(Type:=msoControlButton)
With Boton
.Caption = "Ordena 351 para revisión"
.FaceId = 6770
.OnAction = "Tablas_Dinamica_351"
End With


End Sub

Sub cerrar_barra()
On Error Resume Next
CommandBars("Awen").Delete
CommandBars("Aux").Delete
End Sub

COMO GENERAR PLANO CON LARGOS DE MAS DE 240 caracteres

Sub ExportText()

Application.ScreenUpdating = False

Range("A2").Select
Selection.CurrentRegion.Select


Dim delimiter As String
Dim quotes As Integer
Dim Returned As String

delimiter = ""

quotes = MsgBox("rodear a la información de celda con comillas?", vbYesNo)

' Call the WriteFile function passing the delimiter and quotes options.
Returned = WriteFile(delimiter, quotes)

' Print a message box indicating if the process was completed.
Select Case Returned
Case "Canceled"
MsgBox "la exportacion fue Cancelada."
Case "Exported"
MsgBox "la information fue Exportado."
End Select

End Sub

'-------------------------------------------------------------------

Function WriteFile(delimiter As String, quotes As Integer) As String

' Dimension variables to be used in this function.
Dim CurFile As String
Dim SaveFileName
Dim CellText As String
Dim RowNum As Integer
Dim ColNum As Integer
Dim FNum As Integer
Dim TotalRows As Double
Dim TotalCols As Double


' Show Save As dialog box with the .TXT file name as the default.
' Test to see what kind of system this macro is being run on.
If Left(Application.OperatingSystem, 3) = "Win" Then
SaveFileName = Application.GetSaveAsFilename(CurFile, _
"Text Delimited (*.txt), *.txt", , "Text Delimited Exporter")
Else
SaveFileName = Application.GetSaveAsFilename(CurFile, _
"TEXT", , "Text Delimited Exporter")
End If

' Check to see if Cancel was clicked.
If SaveFileName = False Then
WriteFile = "Canceled"
Exit Function
End If
' Obtain the next free file number.
FNum = FreeFile()

' Open the selected file name for data output.
Open SaveFileName For Output As #FNum

' Store the total number of rows and columns to variables.
TotalRows = Selection.Rows.Count
TotalCols = Selection.Columns.Count

' Loop through every cell, from left to right and top to bottom.
For RowNum = 1 To TotalRows
For ColNum = 1 To TotalCols
With Selection.Cells(RowNum, ColNum)
Dim ColWidth As Integer
ColWidth = Application.RoundUp(.ColumnWidth, 0)
' Store the current cells contents to a variable.
Select Case .HorizontalAlignment
Case xlRight
CellText = Space(Abs(ColWidth - Len(.Text))) & .Text
Case xlCenter
CellText = Space(Abs(ColWidth - Len(.Text)) / 2) & .Text & _
Space(Abs(ColWidth - Len(.Text)) / 2)
Case Else
CellText = .Text & Space(Abs(ColWidth - Len(.Text)))
End Select
End With
' Write the contents to the file.
' With or without quotation marks around the cell information.
Select Case quotes
Case vbYes
CellText = Chr(34) & CellText & Chr(34) & delimiter
Case vbNo
CellText = CellText & delimiter
End Select
Print #FNum, CellText;

' Update the status bar with the progress.
Application.StatusBar = Format((((RowNum - 1) * TotalCols) _
+ ColNum) / (TotalRows * TotalCols), "0%") & " Completed."

' Loop to the next column.
Next ColNum
' Add a linefeed character at the end of each row.
If RowNum <> TotalRows Then Print #FNum, ""
' Loop to the next row.
Next RowNum

' Close the .prn file.
Close #FNum

' Reset the status bar.
Application.StatusBar = False
WriteFile = "Exported"
End Function

?

Published with Blogger-droid v1.6.8

COMO DESDE UN ARCHIVO ABRIR OTRO TRABAJARLO Y PEGARLO DESDE DONDE SE EJECUTA LA MACRO

Sub Libro_Aux()
'***************************ESTO SE PEGA EN EL ARCHIVO ORIGEN DESDE DONDE SE EJECUTA*************************************
Dim wbkOrigen As Workbook
Dim wbktemporal As Workbook

Set wbkOrigen = ActiveWorkbook
'************metodo para abror archivo txt ****************
carga = Application.GetOpenFilename
Workbooks.Open carga
'************metodo para abror archivo txt ****************

'**********************desde aca el lo que se va hacer****************************
Workbooks.OpenText _
Filename:=carga, _
Origin:=xlWindows, _
StartRow:=1, _
DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(31, 1), Array(47 _
, 1), Array(66, 1), Array(79, 1), Array(173, 1), Array(264, 1), Array(299, 1), Array(335, 1) _
), TrailingMinusNumbers:=True


Application.ScreenUpdating = False


Range("A1").Select
Cells.Select
Selection.AutoFilter
Range("A4").Select
Selection.AutoFilter Field:=1, Criteria1:="="
ActiveCell.Offset(1, 0).Range("1:1").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Delete Shift:=xlUp
Selection.AutoFilter Field:=1
Selection.AutoFilter Field:=1, Criteria1:="=----*", Operator:=xlAnd
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlUp
Selection.AutoFilter Field:=1
Selection.AutoFilter Field:=1, Criteria1:="= *", Operator:=xlAnd
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Delete Shift:=xlUp
Selection.AutoFilter Field:=1
Selection.AutoFilter Field:=1, Criteria1:="=Cuenta*", Operator:=xlAnd
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Delete Shift:=xlUp
Selection.AutoFilter Field:=1
Selection.AutoFilter Field:=1, Criteria1:="=Negocio:*", Operator:=xlAnd
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlUp
Selection.AutoFilter Field:=1
Selection.AutoFilter Field:=1, Criteria1:="=Oficina:*", Operator:=xlAnd
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Delete Shift:=xlUp
Selection.AutoFilter Field:=1
ActiveWindow.Zoom = 80
Columns("A:K").EntireColumn.AutoFit
Range("F4").Select
Selection.ClearContents
Columns("F:K").Select
Selection.Style = "Comma"

Range("A1").Select

Rows("1:3").Delete

Columns("E:E").Select
Selection.TextToColumns Destination:=Range("E1"), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 9), Array(3, 1)), TrailingMinusNumbers:=True
Columns("F:F").EntireColumn.AutoFit
Range("J2").Select
ActiveCell.FormulaR1C1 = "=+IF(RC[-3]=0,RC[-2],-RC[-3])"
Range("J2").Select
Selection.Copy
Range("I2").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Select
Range(Selection, Selection.End(xlUp)).Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("J:J").Select

Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("A:J").EntireColumn.AutoFit
Columns("A:J").Select
Columns("A:J").EntireColumn.AutoFit
Range("A2").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Application.CutCopyMode = False
Selection.Copy


'**********************hasta aca el lo que se va hacer****************************

Set wbktemporal = ActiveWorkbook ' se define que es el libro que esta activo la variable


wbktemporal.Close SaveChanges:=False ' se cierra el archivo en donde se trabaja y los valores quedan guardados en el portapapeles por defecto hay quer hacer que si para que los guarde

wbkOrigen.Activate ' se activa el archivo donde esta guardada la macro

Sheets("Datos").Select ''' esta hoja es del archivo origen
ActiveSheet.Paste

End Sub

Hacer un mensaje con VBOKCANCEL y que hacer en cada opcion

i = MsgBox("Desea Continuar", vbOKCancel)

If i = vbCancel Then
ActiveWorkbook.Close'lo que se quiere hacer en caso de que sea Cancel
Exit Sub
Else
i = vbOK
End If

' codigo que es lo que se quiere hacer en caso de que se OK

COMO CREAR USERFORM PARA INCLUIR DATOS EN EXCEL y PROTEGER-DESPROTEGER CON CONTRASEÑA

ABRIR ARCHIVO DESDE CUALQUIER UBICACION

Private Sub Workbook_Open()
carga = Application.GetOpenFilename
Workbooks.open carga
End Sub

COMO HACER QUE SUME POR COLORES

Function Sumarcolor(Celdacolor As Range, Rangosuma As Range) As Double
Dim celda As Range
For Each celda In Rangosuma
If celda.Interior.ColorIndex = Celdacolor.Cells(1, 1).Interior.ColorIndex Then Sumarcolor = Sumarcolor + celda
Next celda
Set celda = Nothing
End Function

Uso de Variables VBA EXCEL - Macros VBA EXCEL

Para que :Se emplean para "GUARDAR" y "MANIPULAR VALORES ó DATOS "

Tipos de Datos:

-numericos ---> Myvarnum=5000 'guardando el dato numerico "5000" en "Myvarnum"
-cadenas ---> Myvarcadena="Libro39" 'guardando la cadena "Libro39" en Myvarcadena
-objetos ---> set wbk=Activeworkbook ''asig¡nando el libro activo a la variable de tipo objeto "wbk"

-variantes ----->myvar=5000 , myvar="XXX" , set myvar=Activeworkbook
'y en las varables de tipo variant uno podra almacenar un dato de diferentes tipos.

Las varibles se declaran de la sgte manera
-------------------------------------------


Dim var_ejemplo as string


Dim : Indica la declaración d ela variable
var_ejemplo :nombre de la variable
As : cualificativo para separar el "nombre de la varible" del "tipo de dato"
String : El tipo de dato (puede ser string ,integer, object , variant ,etc,etc)

Dim Myvarnum as integer 'tipo..numerico
Dim Myvarcadena as string 'tipo...cadena
Dim wbk as object 'tipo...objeto
Dim myvar as variant 'tipo...variant

*Varibles de objeto
---------------------
empleadas par refrenciar un objeto

*ojo para asignar un objeto a una variable uno debe asignar
de la sgte forma..primero

colocar set..luego nombre de la variable e igualr al objeto.

Set variable=Objeto

Ejemplo
--------

Dim wbk as object
-asignamos el objeto ===> el libro activo(Activeworkbook) a la variable "wbk"
set wbk=Activeworkbook
-y luego podremos por ejemplo decir
Msgbox wbk.name 'y obtendremos el nombre del libro activo


Ambito de las variables
------------------------
Se refiere al área donde se puede acceder.



'-a nivel de procedimiento
'-------------------------

Sub procedim 'las varibles solo seran acesibles dentro del procedimiento

dim paraproc as string
dim paraprox as string
paraproc="Real Madrid"
paraprox="Barcelona"

End sub

'-a nivel de modulo
'----------------------

Dim superclub as string 'accesible a todos los procedimientos del modulo


sub prueba
superclub="Manchester United"
End sub

'-a nivel de proyecto
'---------------------

Option Explicit

'al declara la variable como publica ser accesible desde todo el proyecto

Public superclub As String
Sub prueba1()

superclub = "Inter de Milan"

Fuente: http://excel-vba-code.blogspot.com/2008/02/uso-de-variables-vba-excel-macros-vba.html

RUTINA PARA ELIMINAR CELDAS IGUALES EN EXCEL

Do Until ActiveCell = ""
If ActiveCell = ActiveCell.Offset(0, 1) Then
ActiveCell.EntireRow.Delete
End If
ActiveCell.Offset(1, 0).Activate
Loop