Macro extrae datos en base a criterios y concatena los datos obtenidos


Este procedimiento de VBA o macro de Excel, recorre todas las filas y todas las columnas del libro de Excel, buscando sólo celdas con datos, en caso de encontrarlas las coloca en la columna L y fila correspondiente, se saltea todas las celdas vacías y en caso de encontrar datos nuevamente antes del final de la búsqueda vuelve a copiar los datos en la columna siguiente a la L y así sucesivamente; la particularidad de la macro es que si encuentra datos los va concatenando y lo que guarda es una concatenación de todos los datos que no están vacío, es un ejemplo más de como recorrer celdas mediante bucles y obtener datos de acuerdo a ciertos criterios, esta pregunta me la hicieron en un foro y me pareció interesante agregarla para que puedan ver como trabaja el código, ya que además de que la celda contenga datos se debe tener en cuenta ir concatenando los resultados y hacer una cadena con esos datos, una vez que encuentra una celda vacía deja de concatenar y empieza nuevamente cuando encuentra una celda con datos, pero estos datos ya pertenecen a otra cadena de textos,  haz click para bajar el ejemplo.

Te recomiendo que leas un excelente libro sobre Excel para ello haz click acá, si quieres un libro sobre Excel, en inglés, entonces debes hacer click acá.

El código que se encuentra a continuación se debe ingresar en un módulo, descargando el ejemplo lo podrás ver en funcionamiento, analizar, modificar y adaptar a lo que tú estés realizando el código está abierto sin ningún tipo de restricción.




Código a insertar en módulo


Sub extrae()
Dim fila, col1, col2, conta, conta1, conta2 As Integer
Dim str, strT As String
fila = 1
col1 = 1
col2 = 12
conta = 1
conta1 = 1
conta2 = 0
While conta < 20
   
   While conta1 < 10
        If Sheets("hoja1").Cells(fila, col1) <> Empty Then
           conta2 = 0
           str = Sheets("hoja1").Cells(fila, col1).Text
           strT = strT & str
           Sheets("hoja1").Cells(fila, col2) = strT
        Else
        conta2 = conta2 + 1
        strT = Empty
        End If
       
        If strT = Empty And Sheets("hoja1").Cells(fila, 12) <> Empty And conta2 = 1 Then
        col2 = col2 + 1
        End If
  col1 = col1 + 1
  conta1 = conta1 + 1
  Wend
 
  strT = Empty
 
fila = fila + 1
col1 = 1
col2 = 12
conta = conta + 1
conta1 = 1
conta2 = 0
Wend

End Sub




Si te fue de utilidad puedes INVITARME UN CAFÉ y de esta manera ayudar a seguir manteniendo la página, CLICK para descargar en ejemplo en forma gratuita.




If this post was helpful INVITE ME A COFFEE and so help keep up the page, CLICK to download free example.

Si te gustó por favor compártelo con tus amigos
If you liked please share it with your friends      

Macro VBA recorre hojas en busca de stock cero





Este procedimiento de VBA o macro de Excel, recorre todas las hojas de Excel predeterminadas donde se encuentran los productos listados, luego en cada hoja recorre todas las filas que tengan datos, en busca de valores iguales a cero, que sería el stock del producto listado, una vez detectado los valores cero los copia por medio de macro de VBA en otra hoja de Excel para hacer un resúmen de todos los productos que tengan un stock cero,  haz click en el link del final para bajar el ejemplo. Te recomiendo que leas un excelente libro sobre Excel para ello haz click acá.

El código que se encuentra a continuación se debe ingresar en un módulo, descargando el ejemplo lo podrás ver en funcionamiento, analizar, modificar y adaptar a lo que tú estés realizando el código está abierto sin ningún tipo de restricción.



Antes de continuar recomiendo leer un excelente libro sobre Excel que te ayudará operar las planillas u hojas de cálculo, haz click acá, si quieres aprender sobre Excel, en inglés, entonces debes hacer click here. Si lo que necesitas es aprender o profundizar sobre la programación de macros con VBA este es unos de los mejores cursos on line que he visto en internet.


  

En el vídeo a continuación verás una explicación más detallada y gráfica de la macro de ejemplo que se presenta en el post, sugiero ver el vídeo, previamente descargar el archivo para seguir la explicación.

Suscribe a nuestro canal de You Tube para recibir en tu correo vídeos explicativos sobre macros interesantes, como  por ejemplo formulario que crea un listado de todas las hojas para poder luego seleccionarlasbuscar en listbox mientras escribes en textboxordenar hojas libro excel por su nombreconectar Excel con Access y muchos ejemplos más.






Código a insertar en módulo


Sub busca()
Application.ScreenUpdating = False
Dim fila, filat As Integer
fila = 2
filat = 2
While Sheets("silla").Cells(fila, 1) <> Empty
    If Sheets("silla").Cells(fila, 2) = 0 Then
      Sheets("silla").Select
      Rows(fila).Select
      Selection.Copy
      Sheets("Total").Select
      Cells(filat, 1).Select
      Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
      SkipBlanks:=False, Transpose:=False
      Application.CutCopyMode = False
      filat = filat + 1
    End If
fila = fila + 1
Wend
fila = 2
While Sheets("mesas").Cells(fila, 1) <> Empty
    If Sheets("mesas").Cells(fila, 2) = 0 Then
      Sheets("mesas").Select
      Rows(fila).Select
      Selection.Copy
      Sheets("Total").Select
      Cells(filat, 1).Select
      Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
      SkipBlanks:=False, Transpose:=False
      Application.CutCopyMode = False
      filat = filat + 1
    End If
fila = fila + 1
Wend
fila = 2
While Sheets("libros").Cells(fila, 1) <> Empty
    If Sheets("libros").Cells(fila, 2) = 0 Then
      Sheets("libros").Select
      Rows(fila).Select
      Selection.Copy
      Sheets("Total").Select
      Cells(filat, 1).Select
      Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
      SkipBlanks:=False, Transpose:=False
      Application.CutCopyMode = False
      filat = filat + 1
    End If
fila = fila + 1
Wend
fila = 2
While Sheets("peliculas").Cells(fila, 1) <> Empty
    If Sheets("peliculas").Cells(fila, 2) = 0 Then
      Sheets("peliculas").Select
      Rows(fila).Select
      Selection.Copy
      Sheets("Total").Select
      Cells(filat, 1).Select
      Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
      SkipBlanks:=False, Transpose:=False
      Application.CutCopyMode = False
      filat = filat + 1
    End If
fila = fila + 1
Wend
fila = 2
While Sheets("juegos").Cells(fila, 1) <> Empty
    If Sheets("juegos").Cells(fila, 2) = 0 Then
      Sheets("juegos").Select
      Rows(fila).Select
      Selection.Copy
      Sheets("Total").Select
      Cells(filat, 1).Select
      Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
      SkipBlanks:=False, Transpose:=False
      Application.CutCopyMode = False
      filat = filat + 1
    End If
fila = fila + 1
Wend
Application.ScreenUpdating = True
End Sub




Si te fue de utilidad puedes INVITARME UN CAFÉ y de esta manera ayudar a seguir manteniendo la página, CLICK para descargar en ejemplo en forma gratuita.




If this post was helpful INVITE ME A COFFEE and so help keep up the page, CLICK to download free example.



Si te gustó por favor compártelo con tus amigos
If you liked please share it with your friends      

Formato Negrita solo a Mayúsculas


Este procedimiento de VBA o macro de Excel, recorre todas las filas mientras no estén, en caso de encontrar una cadena de texto en Mayúscula le da formato negrita, una vez recorrida hasta la última fila de la columna, pasa a la columna siguiente y así hasta la última columna con datos del ahoja de Excel,  haz click en el link del final para bajar el ejemplo. Te recomiendo que leas un excelente libro sobre Excel para ello haz click acá. El código que se encuentra a continuación se debe ingresar en un módulo, descargando el ejemplo lo podrás ver en funcionamiento, analizar, modificar y adaptar a lo que tú estés realizando el código está abierto sin ningún tipo de restricción.



Código a insertar en módulo


Sub NegritaaMayuscula()
Dim cadena As String
Dim fila, col As Integer
fila = 2
col = 1
While Sheets("hoja1").Cells(fila, col) <> Empty
  
   While Sheets("hoja1").Cells(fila, col) <> Empty
       cadena = Sheets("hoja1").Cells(fila, col)
     If UCase(cadena) = cadena Then
        Cells(fila, col).Select
        Selection.Font.Bold = True
     End If
   fila = fila + 1
Wend
fila = 2
col = col + 1
Wend
End Sub



Si te fue de utilidad puedes INVITARME UN CAFÉ y de esta manera ayudar a seguir manteniendo la página, CLICK para descargar en ejemplo en forma gratuita.



If this post was helpful INVITE ME A COFFEE and so help keep up the page, CLICK to download free example.


Si te gustó por favor compártelo con tus amigos
If you liked please share it with your friends      

Macro VBA copia registro dependiendo de criterios


 Procedimiento de VBA para Excel, me preguntaron como se podía hacer para exportar datos de una hoja a otra, donde sólo se debían copiar ciertos datos y que cumplan varios criterios; bien eso es lo que hace este ejemplo mediante una Macro. Primero determina si los registros que se encuentran en la fila analizada se deben o no exportar, en caso afirmativo revisa si los datos de determinadas columnas cumplen un requisito, en caso positivo se copia esa columna, en caso negativo otra columna distinta, a su vez copia otra serie de registros que sólo dependen del primer criterio; haz click en el link del final para bajar el ejemplo. Te recomiendo que leas un excelente libro sobre Excel para ello haz click acá. El código que se encuentra a continuación se debe ingresar en un módulo, descargando el ejemplo lo podrás ver en funcionamiento, analizar, modificar y adaptar a lo que tú estés realizando el código está abierto sin ningún tipo de restricción.


Código a insertar en módulo


Sub exporta()
Application.ScreenUpdating = False
On Error Resume Next
Dim filaex, filaim, conta As Integer
filaex = 6
filaim = 2
conta = 0
While Sheets("Libro").Cells(filaex, 1) <> Empty
    If Sheets("Libro").Cells(filaex, 27) = "SI" Then
        Sheets("Caja Diaria").Cells(filaim, 1) = Sheets("Libro").Cells(filaex, 1)
        Sheets("Caja Diaria").Cells(filaim, 2) = Sheets("Libro").Cells(filaex, 2)
        Sheets("Caja Diaria").Cells(filaim, 3) = Sheets("Libro").Cells(filaex, 3)
        Sheets("Caja Diaria").Cells(filaim, 4) = Sheets("Libro").Cells(filaex, 6)
       
          If Sheets("Libro").Cells(filaex, 7) > 0 Then
                Sheets("Caja Diaria").Cells(filaim, 5) = Sheets("Libro").Cells(filaex, 7)
          Else
                Sheets("Caja Diaria").Cells(filaim, 5) = Sheets("Libro").Cells(filaex, 23)
          End If
         
          If Sheets("Libro").Cells(filaex, 8) > 0 Then
                Sheets("Caja Diaria").Cells(filaim, 6) = Sheets("Libro").Cells(filaex, 8)
          Else
                Sheets("Caja Diaria").Cells(filaim, 6) = Sheets("Libro").Cells(filaex, 24)
          End If
    conta = conta + 1
    filaim = filaim + 1
    End If
filaex = filaex + 1
Wend
MsgBox ("Se exportaron con éxito " & conta & " registros"), vbInformation
Application.ScreenUpdating = False
End Sub



Si te fue de utilidad puedes INVITARME UN CAFÉ y de esta manera ayudar a seguir manteniendo la página, CLICK para descargar en ejemplo en forma gratuita.



If this post was helpful INVITE ME A COFFEE and so help keep up the page, CLICK to download free example.

Si te gustó por favor compártelo con tus amigos
If you liked please share it with your friends      

Cronómetro con VBA para Excel

Procedimiento de VBA o Macro de Excel, si  descargas el ejemplo podrás ver tres  botones, apretando el botón iniciar, da inicio  al  cronometro, este corre  hasta que se haga click en el botón detener, copiando los datos del último contador antes de ser detenido.  Si se vuelve a hacer click en iniciar borra los datos anteriores y coloca la hora actual reiniciando el ciclo nuevamente si se detiene se copian los datos y así sucesivamente, el ejemplo de este cronometro se puede adaptar a cada aplicación, incluso puede ponerse en un formulario. Haciendo click en el link del final podrás descargar el ejemplo.

Te recomiendo que leas un excelente libro sobre Excel para ello haz click acá. El código se encuentra a continuación se debe ingresar en un módulo, descargando el ejemplo lo podrás ver en funcionamiento, analizar, modificar y adaptar a lo que tú estés realizando el código está abierto sin ningún tipo de restricción.


Código a insertar en módulo,
Option Explicit
Dim hssig, hsini As Date
Private Sub FinCron()
Application.ScreenUpdating = False
On Error Resume Next
Application.OnTime hssig, "Actualiza", , False
End Sub
Private Sub Actualiza()
'Asignar hs a celda
Sheets("hoja1").Range("h2").Value = Now - Sheets("hoja1").Range("f2").Value
hssig = Now + (1 / 86400)
Application.OnTime hssig, "Actualiza"
End Sub
Private Sub IniciaCron()
    Actualiza
    hsini = Now
    Sheets("hoja1").Range("f2").Value = FormatDateTime(hsini, vbLongTime)
    Sheets("hoja1").Range("g2").Value = ""
End Sub
Private Sub StopCron()
    FinCron
    Dim UF As Long
    With Sheets("hoja1")
        .Range("g2").Value = FormatDateTime(Now(), vbLongTime)
        .Range("h2").Value = FormatDateTime(.Range("g2") - .Range("f2"), vbLongTime)
         UF = .[F1048576].End(xlUp).Row + 1
        .Cells(UF, 6).Value = .[f2].Value
        .Cells(UF, 7).Value = .[g2].Value
        .Cells(UF, 8).Value = [h2].Value
        .Range("f" & UF & ":h" & UF).NumberFormat = "h:mm:ss"
    End With
End Sub
Private Sub reset()
Sheets("hoja1").Range("a1:xdf1048576").ClearContents
Columns("h:h").Select
Selection.NumberFormat = "hh:mm:ss;@"
End Sub 





Si te fue de utilidad puedes INVITARME UN CAFÉ y de esta manera ayudar a seguir manteniendo la página, CLICK para descargar en ejemplo en forma gratuita.




If this post was helpful INVITE ME A COFFEE and so help keep up the page, CLICK to download free example.

Si te gustó por favor compártelo con tus amigos
If you liked please share it with your friends      

Facebook prehistorico






Humor Gráfico




MASTERCARD PAYONEER
  1. Trucos de Excel
  2. Macro que envía mail y emite formulario de aviso
  3. Macro Alerta mediante parpadeo de celda
  4. Glosario de palabras usadas en VBA para Excel
  5. Forma de seleccionar o hacer referencia a celdas, rangos y hojas






Si te gustó por favor compártelo con tus amigos
If you liked please share it with your friends      

Buscar datos en tres columnas con Macro de VBA





Este procedimiento de VBA o Macro de Excel busca un dato en la hoja 1, comparándolo con los datos de la hoja 1 en caso de no encontrarse el dato, éste es copiado en la hoja 3; para comparar

El código se encuentra a continuación, igualmente descargando el ejemplo lo podrás ver en funcionamiento, analizar, modificar y adaptar  a lo que tú estés realizando el  código está abierto sin ningún tipo de restricción.


Antes de continuar recomiendo leer un excelente libro sobre Excel que te ayudará operar las planillas u hojas de cálculo, haz click acá, si quieres aprender sobre Excel, en inglés, entonces debes hacer click here. Si lo que necesitas es aprender o profundizar sobre la programación de macros con VBA este es unos de los mejores cursos on line que he visto en internet.




  



La macro toma desde el primer al último registro de la hoja, lo compara con los registros de la hoja 2 en caso de no existir los copia en la hoja 3, en el vídeo a continuación encontrarás una explicación más gráfica y detallada del ejemplo presentado.

Suscribe a nuestro canal de You Tube para recibir en tu correo vídeos explicativos sobre macros interesantes, como  por ejemplo formulario que crea un listado de todas las hojas para poder luego seleccionarlasbuscar en listbox mientras escribes en textboxordenar hojas libro excel por su nombreconectar Excel con Access y muchos ejemplos más.






Sub BuscaDatosCoicidentes()
Application.ScreenUpdating = False
Dim fila, filat, uc1, uc2 As Integer
Dim d1, d2, d3, d4, d5, d6 As String
Dim b, con1, con2 As String
fila = 2
fila1 = 2
filat = 2

Sheets("Hoja3").Select
Range("a2:XFD1048576").Clear
uc1 = Sheets("Hoja1").Cells(1, Columns.Count).End(xlToLeft).Column
uc1 = uc1 + 1
uc2 = Sheets("Hoja2").Cells(1, Columns.Count).End(xlToLeft).Column
uc2 = uc2 + 1
While Sheets("Hoja1").Cells(fila, 1) <> Empty
d1 = Sheets("Hoja1").Cells(fila, 4).Text
d2 = Sheets("Hoja1").Cells(fila, 5).Text
d3 = Sheets("Hoja1").Cells(fila, 7).Text
con1 = d1 & d2 & d3
Sheets("Hoja1").Cells(fila, uc1) = con1
fila = fila + 1
Wend
fila = 2
While Sheets("Hoja2").Cells(fila, 1) <> Empty
d4 = Sheets("Hoja2").Cells(fila, 4).Text
d5 = Sheets("Hoja2").Cells(fila, 5).Text
d6 = Sheets("Hoja2").Cells(fila, 7).Text
con2 = d4 & d5 & d6
Sheets("Hoja2").Cells(fila, uc2) = con2
fila = fila + 1
Wend
fila = 2
While Sheets("Hoja1").Cells(fila, uc1) <> Empty
dato = Sheets("Hoja2").Cells(fila, uc2)
Set b = Sheets("Hoja1").Columns(uc1).Find(dato, LookIn:=xlValues, Lookat:=xlWhole)

If b Is Nothing Then
Sheets("Hoja2").Select
Rows(fila).Select
Selection.Copy
Sheets("Hoja3").Select
Cells(filat, 1).Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
filat = filat + 1
End If
fila = fila + 1
Wend
Sheets("Hoja3").Columns(5).Select
Selection.NumberFormat = "#,##0"
Application.CutCopyMode = False
Sheets("Hoja1").Columns(uc1).Clear
Sheets("Hoja2").Columns(uc2).Clear
Sheets("Hoja3").Columns(uc2).Clear
Set b = Nothing
Application.ScreenUpdating = False
End Sub



Si te fue de utilidad puedes INVITARME UN CAFÉ y de esta manera ayudar a seguir manteniendo la página, CLICK para descargar en ejemplo en forma gratuita.



If this post was helpful INVITE ME A COFFEE and so help keep up the page, CLICK to download free example.

Si te gustó por favor compártelo con tus amigos
If you liked please share it with your friends      

Insertar columnas


Insertar columnas con VBA  ó macros, me preguntaron en un foro de Excel como se insertaban columnas teniendo en cuenta los meses del año, como así también que el informe original no otorgara datos de meses en los cuales no había movimientos, por ello era necesario agregar columnas en base a los meses que faltaban y a su vez se tenía  que rellenar con ceros, en este ejemplo se insertan tantas columnas como sean necesarias  para que queden en orden correlativo del 1 al 12, simulando los meses, determina  cual es la última fila con valores de todas las columnas, en base a ello rellena hasta esa fila con ceros si no hay valor  que sea distinto de éste, en el link del final se encuentra el archivo que puedes descargar y adaptar a tus necesidades; te recomiendo que hagas click y leas un  excelente libro sobre el tema; aquí va el código:


Sub insertacol()
Application.ScreenUpdating = False
Dim fila, col, x, uf, ufmayor, dato As Integer
fila = 1
col = 1
x = 0
For x = 1 To 12
      dato = Sheets("hoja1").Cells(fila, x).Value
   If dato <> x Then
      Sheets("hoja1").Cells(fila, x).EntireColumn.Insert
      Sheets("hoja1").Cells(fila, x) = x
      Sheets("hoja1").Cells(fila, x).Select
    
      With Selection
           .NumberFormat = "000"
           .Font.Bold = True
      End With
   End If
   'col = col + 1
Next x
x = 0
For x = 1 To 12
     'Determino la última fila vacia
    uf = Sheets("hoja1").Cells(Rows.Count, x).End(xlUp).Row
    If uf > ufmayor Then
    ufmayor = uf
    End If
Next x
x = 0
'Recorre columnas
For x = 1 To 12
     'Recorre filas
     For j = 2 To ufmayor
          'Determino cual es la columna que tiene la fila maxina de datos
          'Con ello se hasta donde rellenar con ceros, siempre que la celda este vacía
          If Sheets("hoja1").Cells(j, x) = Empty Then
             Sheets("hoja1").Cells(j, x) = 0
          End If
    Next j
   
Next x
Application.ScreenUpdating = False
End Sub




Si te fue de utilidad puedes INVITARME UN CAFÉ y de esta manera ayudar a seguir manteniendo la página, CLICK para descargar en ejemplo en forma gratuita.



If this post was helpful INVITE ME A COFFEE and so help keep up the page, CLICK to download free example.

Si te gustó por favor compártelo con tus amigos
If you liked please share it with your friends      


Determina días laborales entre fecha y fecha


En este ejemplo podrás observar como al hacer click en el botón corre una macro que calcula los días hábiles del período calcula en  forma simple los días laborales, siendo estos de lunes a viernes, teniendo en cuenta el listado de días feriados que le debemos proporcionar. La macro recorre fila por fila hasta el final y determina los días hábiles del período seleccionado. Te recomiendo que hagas click para aprender más sobre  Excel.






Código que se incorpora en módulo



Private Sub WorksDays()
Application.ScreenUpdating = False
On Error Resume Next
Dim fila, filaf, dh, dnh As Integer
Dim dato1, dato2 As Date
fila = 2
filaf = 2

While Sheets("Hoja1").Cells(fila, 1) <> Empty
     
   
        dato1 = Range("B" & fila)
        dato2 = Range("C" & fila)
       
        For Z = dato1 To dato2
              If Weekday(Z) <> 1 And Weekday(Z) <> 7 Then
                 dh = dh + 1
                    While Sheets("feriados").Cells(filaf, 1) <> Empty
                        If Sheets("feriados").Cells(filaf, 1) = i Then
                           dh = dh - 1
                        End If
                        filaf = filaf + 1
                    Wend
              End If
              filaf = 2
        Next Z
       
    Sheets("hoja1").Cells(fila, 4) = dh
fila = fila + 1
filaf = 2
dh = 0
Wend
Application.ScreenUpdating = True
End Sub




Si te fue de utilidad puedes INVITARME UN CAFÉ y de esta manera ayudar a seguir manteniendo la página, CLICK para descargar en ejemplo en forma gratuita.



If this post was helpful INVITE ME A COFFEE and so help keep up the page, CLICK to download free example.

Si te gustó por favor compártelo con tus amigos
If you liked please share it with your friends      


Click Here!

Formulario colorea celdas




Esta macro de Excel, es algo sencilla, pero para algunos es de gran utilidad, el ejemplo de macro esta desarrollado en VBA, presionando el botón se muestra un userform o formulario con una serie de cuadros de controles; al presionar el botón buscar, se corre un procedimiento de VBA que busca datos en la columna determinada previamente, una vez encontrado el dato buscado, se colorea la celda, procediendo a llenanr los textbox con datos de la columna B, el botón clear quita el color a todas las celdas. Esta macros es bastante similar o ser relación con el ejemplo presentado en el post recorre filas y agrega el número de la fila correspondiente en base a criterios.

Código que se inserta en formulario





Private Sub CommandButton1_Click()
'Dimensiono variables
Dim fila, conta As Integer
Dim dato As Currency
conta = 0
fila = 1
'Variable dato es igual al valor del textbox12
dato = TextBox12
'Realizo bucle para buscar datos, encontrado se aplica el formato
While Sheets("hoja1").Cells(fila, 1) <> emtpy
    If Sheets("hoja1").Cells(fila, 1) = dato Then
      
       Sheets("hoja1").Cells(fila, 1).Select
      With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .color = 65535
            .TintAndShade = 0
            .PatternTintAndShade = 0
      End With
       TextBox1 = ActiveCell.Offset(0, 1).Value
     Else
     conta = 1
    End If
 fila = fila + 1
  Wend
'Si no encontró el dato sale un mensaje
If conta = 1 Then
 MsgBox ("No se encontró ID  " & dato), vbInformation, "AVISO"
End If
End Sub
Private Sub CommandButton2_Click()
Unload Me
End Sub
Private Sub CommandButton3_Click()
 Sheets("hoja1").Range("A:A").Select
 With Selection.Interior
            .Pattern = xlNone
            .TintAndShade = 0
            .PatternTintAndShade = 0
      End With


End Sub


Código que se inserta en un módulo


Sub llamaform()
UserForm1.Show
End Sub


CLICK para descargar en ejemplo en forma gratuita, si te fue de utilidad puedes INVITARME UN CAFÉ y de esta manera ayudar a seguir manteniendo la página.


CLICK to download free example, If this post was helpful INVITE ME A COFFEE and so help keep up the page.


Si te gustó por favor compártelo con tus amigos
If you liked please share it with your friends      

Calcular saldo entre fecha y fecha




Este procedimiento de VBA o Macro de Excel determina el saldo por proveedor o puede usarse para clientes, entre fecha y fecha, también se puede adaptar el ejemplo para tener gestionada una cuenta bancaria propia como por ejemplo la de MASTERCARD PAYONEER (si aún no la  tienes puedes gestionarla desde  el siguiente link); entregando un informe detallado de todos los movimientos que ha tenido la cuenta en el períodos seleccionado,  o si  se tilda la casilla correspondiente hace un resumen de todas la cuentas que tengan saldo distinto de cero, emitiendo un listado con todos los saldos dentro de los 60 días anteriores a la fecha del sistema; haciendo click en el link del final podrás descargar el ejemplo. 

Te recomiendo que leas un excelente libro sobre Excel para ello haz click acá. El código se encuentra a continuación, igualmente descargando el ejemplo lo podrás ver en funcionamiento, analizar, modificar y adaptar  a lo que tú estés realizando el  código está abierto sin ningún tipo de restricción.



Código que se introduce en formulario




Private Sub CheckBox1_AfterUpdate()
If CheckBox1.Value = True Then
TextBox3.Enabled = False
ComboBox1.Enabled = False
TextBox1.Enabled = False
TextBox2.Enabled = False
Else
TextBox3.Enabled = True
ComboBox1.Enabled = True
TextBox1.Enabled = True
TextBox2.Enabled = True
End If
End Sub


Private Sub ComboBox1_AfterUpdate()
Dim quebusco As String
Dim rangoabuscar As String
Dim busca As Object
Dim numerocuenta As String
rangoabuscar = "b2:b10000"
quebusco = ComboBox1.Value
Set busca = Sheets("Proveedores").Range(rangoabuscar).Find(quebusco, LookIn:=xlValues, LookAt:=xlWhole)
If Not busca Is Nothing Then
TextBox3.Value = busca.Offset(0, -1)
Else
ComboBox1.SetFocus
MsgBox "El Proveedor no existe", vbCritical
End If
TextBox1 = CDate(Date - 60)
TextBox2 = CDate(Date)
End Sub
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
'Controlo errores
On Error Resume Next
'Busca todos los Proveedores con saldo mayor a 0, si el checkbox es igual a true
If CheckBox1.Value = True Then
'Muestra progressbar
Unload Me
ProgressForm.Show False
Dim R As Integer
Dim MT As Double
For R = 1 To 10
 MT = Timer
 ProgressForm.ProgressBar1.Max = 10
 Do
  Loop While Timer - MT < 0.05
   ProgressForm.ProgressBar1.Value = R
 DoEvents
Next R
Unload ProgressForm

'Borra el contenido de la hoja saldo antes de empezar a calcular y pegar en celdas
Sheets("saldo").Visible = True
Sheets("saldo").Select
Sheets("saldo").Unprotect Password:="1111"
Range("d5:d7,c6,c10,f7,f5:g5,e10:f10,c10:h65536").ClearContents
'Busca los facturas ingresadas
Dim filafacturasST As Integer
Dim filapagosST As Integer
Dim filaProveedoresST As Integer
Dim filasaldoST As Integer
Dim facturasST As Currency
Dim AcumulafacturasST As Currency
Dim pagosST As Currency
Dim AcumulaPagoST As Currency
Dim saldoST As Currency
Dim cond1ST As String
Dim cond2ST As String
Dim cond3ST As String
Dim valor As Integer
Dim midate As Date

Dim dato1ST As String
Dim dato2ST As String
Dim dato3ST As String

filafacturasST = 2
filapagosST = 2
filaProveedoresST = 2
filasaldoST = 10
cond1ST = "Cancelada"
cond2ST = "Anulada"
cond3ST = "Falso"
'Busca importe de facturas
 Sheets("dbcomp").Visible = True
 Sheets("Proveedores").Visible = True

 While Sheets("Proveedores").Cells(filaProveedoresST, 2) <> Empty
           dato1ST = Sheets("Proveedores").Cells(filaProveedoresST, 2).Value
          
        While Sheets("dbcomp").Cells(filafacturasST, 3).Value <> Empty
                    
                 If dato1ST = Sheets("dbcomp").Cells(filafacturasST, 3).Value <> Empty And _
                    Sheets("dbcomp").Cells(filafacturasST, 13).Value <> cond2ST Then
                     facturasST = Sheets("dbcomp").Cells(filafacturasST, 8).Value
                     
                     filafacturasST = filafacturasST + 1
                  
                 Else
                     filafacturasST = filafacturasST + 1
                 End If
       AcumulafacturasST = AcumulafacturasST + facturasST
       facturasST = 0
       Wend
      
                     
     'Seguidamente busca pagos realizados antes de la ficha inicial
        While Sheets("dbcomp").Cells(filapagosST, 3).Value <> Empty
              dato2ST = Sheets("dbcomp").Cells(filapagosST, 13).Value
              dato3ST = Sheets("dbcomp").Cells(filapagosST, 9).Value
       
                 If dato1ST = Sheets("dbcomp").Cells(filapagosST, 3).Value And _
                    (dato2ST = cond1ST Or dato3ST = cond3ST) Then
                                  
                 pagosST = Sheets("dbcomp").Cells(filapagosST, 8).Value
       
                 filapagosST = filapagosST + 1
                Else
                 filapagosST = filapagosST + 1
                End If
       
        AcumulaPagoST = AcumulaPagoST + pagosST
        pagosST = 0
        Wend
       
   saldoST = AcumulafacturasST - AcumulaPagoST

   If saldoST <> 0 Then
   Sheets("saldo").Cells(filasaldoST, 3).Value = Date
   Sheets("saldo").Cells(filasaldoST, 4).Value = UCase(Sheets("Proveedores").Cells(filaProveedoresST, 2).Value)
   Sheets("saldo").Cells(filasaldoST, 5).Value = AcumulaPagoST
   Sheets("saldo").Cells(filasaldoST, 6).Value = AcumulafacturasST
   Sheets("saldo").Cells(filasaldoST, 7).Value = saldoST
  
   Sheets("saldo").Range("d5") = "Todas"
   Sheets("saldo").Range("d6") = "Todos"
   Sheets("saldo").Range("d7") = midate
   Sheets("saldo").Range("c6") = "Proveedores:"
  
   filasaldoST = filasaldoST + 1
  
   End If
 
  filaProveedoresST = filaProveedoresST + 1
  AcumulafacturasST = 0
  AcumulaPagoST = 0
  saldoST = 0
  filafacturasST = 2
  filapagosST = 2
Wend
'Ordena por fecha en forma ascendente y por concepto todo lo que parezca número
  Sheets("SALDO").Select
      Range("C10:h65500").Sort Key1:=Range("C10"), Order1:=xlAscending, Key2:=Range("D10"), _
      Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
      DataOption1:=xlSortTextAsNumbers, DataOption2:=xlSortNormal
'Llama a la rutina para dar formato
 FormatoCeldasSaldo
     
'Determina el total adeudado a los proveedores
valor = 0
Range("g9").Select
While ActiveCell <> Empty
ActiveCell.Offset(1, 0).Select
valor = valor + ActiveCell.Value
Wend
Range("f7") = valor

'Se oculta también la hoja cancela op , porque el saldo puede ser consuldado desde ahí
 'Sheets("cancela oP").Visible = xlVeryHidden
 'Sheets("dbcomp").Visible = xlVeryHidden
 'Sheets("Proveedores").Visible = xlVeryHidden
 Sheets("saldo").Protect Password:="1111"
 Sheets("saldo").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    ActiveSheet.EnableSelection = xlNoSelection
 Sheets("saldo").Activate
 ActiveWindow.ScrollRow = 7
 Unload Me
 Exit Sub
 End If



'Si el check box no está tildado (es falso y quiero conocer el detalle) empieza la rutina desde aquí
'valida datos de el textbox1 Fecha
If Not IsDate(TextBox1.Text) Then
MsgBox "fecha inválida"
TextBox1.SetFocus
Exit Sub
End If
'Valida fecha
Dim ubica1, ubica2 As String
Dim dia, mes As Integer
Dim año, fecha As Integer
On Error Resume Next
'guardamos en variables el caracter encontrado en la posición 3 y 6
ubica1 = Mid(TextBox1.Text, 3, 1)
ubica2 = Mid(TextBox1.Text, 6, 1)
'comparamos si se trata de '/'
If ubica1 <> "/" Or ubica2 <> "/" Then
MsgBox ("Debes ingresar datos con este formato: dd/mm/aa")
TextBox1.SetFocus
Exit Sub
End If
dia = Mid(TextBox1.Value, 1, 2)
mes = Mid(TextBox1.Value, 4, 2)
año = Mid(TextBox1.Value, 7, 4)
fecha = Len(TextBox1)

'Controla lo ingresado, si no se cumple no es fecha y sale en msgbox
If dia > 31 Or mes > 12 Or año < 1900 Or fecha > 10 Then
MsgBox "Fecha incorrecta"
TextBox1.SetFocus
Exit Sub
End If

'valida datos de el textbox2 Fecha
If Not IsDate(TextBox2.Text) Then
MsgBox "fecha inválida"
TextBox2.SetFocus
Exit Sub
End If
'Valida fecha
Dim ubica3, ubica4 As String
Dim dia1, mes1 As Integer
Dim año1, fecha1 As Integer
'guardamos en variables el caracter encontrado en la posición 3 y 6
ubica3 = Mid(TextBox2.Text, 3, 1)
ubica4 = Mid(TextBox2.Text, 6, 1)
'comparamos si se trata de '/'
If ubica3 <> "/" Or ubica4 <> "/" Then
MsgBox ("Debes ingresar datos con este formato: dd/mm/aa")
TextBox2.SetFocus
Exit Sub
End If
dia1 = Mid(TextBox2.Value, 1, 2)
mes1 = Mid(TextBox2.Value, 4, 2)
año1 = Mid(TextBox2.Value, 7, 4)
fecha1 = Len(TextBox2)

'Controla lo ingresado, si no se cumple no es fecha y sale en msgbox
If dia1 > 31 Or mes1 > 12 Or año1 < 1900 Or fecha1 > 10 Then
MsgBox "Fecha incorrecta"
TextBox2.SetFocus
Exit Sub
End If

'Controla que la fecha final no sea menor a la inicial
Dim fechainicio As Date
Dim fechafinal As Date
fechainicio = TextBox1.Value
fechafinal = TextBox2.Value
If fechainicio > fechafinal Then
MsgBox "Fecha inválida"
TextBox2.SetFocus
Exit Sub
End If

'Controla que la fecha inicial no sea mayor a la fecha actual
Dim condicionfecha As Date
condicionfecha = TextBox1.Value
If condicionfecha > Date Then
MsgBox "La fecha inicial no puede ser mayor a la fecha actual"
Exit Sub
End If


If ComboBox1 = Empty Or TextBox1 = Empty Or TextBox2 = Empty Then
MsgBox "Debe completar todos los campos"
ComboBox1.SetFocus
Exit Sub
End If

Unload Me
ProgressForm.Show False
Dim R1 As Integer
Dim MT1 As Double
For R1 = 1 To 10
 MT1 = Timer
ProgressForm.ProgressBar1.Max = 10
 Do
  Loop While Timer - MT1 < 0.05
   ProgressForm.ProgressBar1.Value = R1 '"Progress: " & R & " de 180: " & _
   'Format(R / 180, "Percent") & " --- " & "Cumplimiento"
 DoEvents
Next R1
Unload ProgressForm


'Hace la hoja visible porque si no provoca error
'Selecciona la hoja donde va a pegar datos
'Desproteje la hoja
'Borra el contenido de la hoja saldo antes de empezar a calcular y pegar en celdas
Sheets("saldo").Visible = True
Sheets("saldo").Select
ActiveSheet.Unprotect Password:="1111"
Range("d5:d7,c6,c10,f5:g5,f7,e10:f10,c10:h65536").ClearContents
Sheets("dbcomp").Visible = True

'calcula saldo el saldo inicial para ello primero busca las facturas con fecha
'menor a la fecha inicial y luego los pagos con fecha menor a la fecha inicial
Dim filafacturasSI As Integer
Dim filapagosSI As Integer
Dim factura As Currency
Dim Acumulafactura As Currency
Dim pagos As Currency
Dim AcumulaP As Currency
Dim saldo As Currency
Dim cond1SI As String
Dim cond2SI As Date
Dim cond3SI As String
Dim cond4SI As String
Dim dato1SI As String
Dim dato2SI As Date
Dim dato3SI As String
Dim dato4SI As String

filafacturasSI = 2
filapagosSI = 2
cond1SI = ComboBox1.Value
cond2SI = TextBox1.Value
cond3SI = "Cancelada"
cond4SI = "Anulada"
'Busca importe de facturas menores a la ficha inicial
'Compara si es menor a la fecha inicial y pertenece al Proveedores seleccionado

 While Sheets("dbcomp").Cells(filafacturasSI, 1) <> Empty
            dato1SI = Sheets("dbcomp").Cells(filafacturasSI, 3).Value
            dato2SI = Sheets("dbcomp").Cells(filafacturasSI, 1).Value
           
             
        If dato1SI = cond1SI And _
           dato2SI < cond2SI And _
           Sheets("dbcomp").Cells(filafacturasSI, 13).Value <> cond4SI Then
           
           factura = Sheets("dbcomp").Cells(filafacturasSI, 8).Value
                     
           filafacturasSI = filafacturasSI + 1
          
        Else
           filafacturasSI = filafacturasSI + 1
        End If
       Acumulafactura = Acumulafactura + factura
      factura = 0
       Wend
      
      
      
      
      
     'Seguidamente busca pagos realizados antes de la ficha inicial
 While Sheets("dbcomp").Cells(filapagosSI, 1) <> Empty
            dato1SI = Sheets("dbcomp").Cells(filapagosSI, 3).Value
            dato2SI = Sheets("dbcomp").Cells(filapagosSI, 1).Value
            dato4SI = Sheets("dbcomp").Cells(filapagosSI, 13).Value
       
        If dato1SI = cond1SI And _
           dato2SI < cond2SI And _
           dato4SI = cond3SI Then
                     
          
           pagos = Sheets("dbcomp").Cells(filapagosSI, 8).Value
       
           filapagosSI = filapagosSI + 1
          
        Else
           filapagosSI = filapagosSI + 1
        End If
      AcumulaP = AcumulaP + pagos
      pagos = 0
        Wend
      
saldo = Acumulafactura - AcumulaP
      
      
'Se fija si el saldo es menor o mayor a cero y lo pone en la columna del debe o haber
'Sheets("saldo").Unprotect Password:="1111"
If saldo < 0 Then
Sheets("saldo").Cells(10, 5) = saldo * -1
Sheets("saldo").Cells(10, 7) = saldo
Else
Sheets("saldo").Select
ActiveSheet.Unprotect Password:="1111"
Sheets("saldo").Cells(10, 6) = saldo
Sheets("saldo").Cells(10, 7) = saldo
End If

'Agrega Proveedores de proveedor/cliente, cuenta, fecha etc
Sheets("saldo").Range("d5") = TextBox3.Value
Sheets("saldo").Range("d6") = ComboBox1.Value
Sheets("saldo").Range("d7") = Date
Sheets("saldo").Range("c6") = "Proveedores:"
Sheets("saldo").Range("f5") = CDate(TextBox1)
Sheets("saldo").Range("g5") = CDate(TextBox2)

' Luego de calcular el saldo inicial busca los datos entre las fechas ingresadas

Dim filapagos As Integer
Dim filasaldo As Integer
Dim dato1 As String
Dim dato2 As Date
Dim dato3 As Date
Dim dato4 As String
Dim dato5 As String
Dim dato6 As String
Dim cond1 As String
Dim cond2 As Date
Dim cond3 As Date
filafacturas = 2
filapagos = 2
filasaldo = 11

cond1 = ComboBox1.Value
cond2 = TextBox1.Value
cond3 = TextBox2.Value
'Realiza el bucle en la hoja dbcomp en busca de facturas mietras no haya filas vacias
'Busca facturas según datos ingresados
    While Sheets("dbcomp").Cells(filafacturas, 1) <> Empty
            dato1 = Sheets("dbcomp").Cells(filafacturas, 3).Value
            dato2 = Sheets("dbcomp").Cells(filafacturas, 1).Value
            dato3 = Sheets("dbcomp").Cells(filafacturas, 1).Value
            dato4 = Sheets("dbcomp").Cells(filafacturas, 4).Value
            dato5 = Sheets("dbcomp").Cells(filafacturas, 13).Value
               
        If dato1 = cond1 And _
           dato2 >= cond2 And _
           dato3 <= cond3 And _
           dato4 <> "NC" And _
           dato5 <> "Anulada" Then
         
           'si los datos coinciden con "factura , proveedor/cliente y las fechas los compia en la hoja saldos
          
           Sheets("dbcomp").Cells(filafacturas, 1).Copy Destination:=Sheets("saldo").Cells(filasaldo, 3)
           Sheets("dbcomp").Cells(filafacturas, 4).Copy Destination:=Sheets("saldo").Cells(filasaldo, 4)
           concepto1 = Sheets("dbcomp").Cells(filafacturas, 5)
           concepto2 = Sheets("dbcomp").Cells(filafacturas, 6)
           concepto3 = Sheets("dbcomp").Cells(filafacturas, 7)
           Sheets("saldo").Cells(filasaldo, 4) = Range("d" & filasaldo) & " " & concepto1 & " " & concepto2 & " " & concepto3
           Sheets("dbcomp").Cells(filafacturas, 8).Copy Destination:=Sheets("saldo").Cells(filasaldo, 6)
           Sheets("dbcomp").Cells(filafacturas, 19).Copy Destination:=Sheets("saldo").Cells(filasaldo, 8)
             
           filafacturas = filafacturas + 1
           filasaldo = filasaldo + 1
           Else
           filafacturas = filafacturas + 1
           End If
                   
       Wend
      
      
      
       'Realiza bucle en la hoja dbcomp buscando pagos para realizar las comparaciones y extraer datos coincidentes
       'Busca pagos según datos ingresados
       While Sheets("dbcomp").Cells(filapagos, 1) <> Empty
            dato1 = Sheets("dbcomp").Cells(filapagos, 3).Value
            dato2 = Sheets("dbcomp").Cells(filapagos, 1).Value
            dato3 = Sheets("dbcomp").Cells(filapagos, 1).Value
            dato4 = Sheets("dbcomp").Cells(filapagos, 4).Value
            dato6 = Sheets("dbcomp").Cells(filapagos, 13).Value
           
        If dato1 = cond1 And _
           dato2 >= cond2 And _
           dato3 <= cond3 And _
           dato4 <> "NC" And _
           dato6 = "Cancelada" Then
         
           'si los datos coinciden con el proveedor y las fechas los copia en la hoja saldos
          
           Sheets("dbcomp").Cells(filapagos, 1).Copy Destination:=Sheets("saldo").Cells(filasaldo, 3)
           Sheets("dbcomp").Cells(filapagos, 10).Copy Destination:=Sheets("saldo").Cells(filasaldo, 4)
           Sheets("saldo").Cells(filasaldo, 4) = "Orden de Pago Nº " & Range("d" & filasaldo)
           Sheets("dbcomp").Cells(filapagos, 8).Copy Destination:=Sheets("saldo").Cells(filasaldo, 5)
           Sheets("dbcomp").Cells(filapagos, 19).Copy Destination:=Sheets("saldo").Cells(filasaldo, 8)
          
        filapagos = filapagos + 1
        filasaldo = filasaldo + 1
        Else
           filapagos = filapagos + 1
           End If
                   
       Wend
      
  
     
    
'Ordena por fecha en forma ascendente y por concepto todo lo que parezca número
  Sheets("saldo").Select
      Range("C11:h65500").Sort Key1:=Range("C11"), Order1:=xlAscending, Key2:=Range("D11"), _
      Order2:=xlDescending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
      DataOption1:=xlSortTextAsNumbers, DataOption2:=xlSortNormal
 
'Hace que la fecha del saldo inicial sea igual a la del primer dato
Sheets("saldo").Range("c10") = TextBox1 'Sheets("saldo").Range("c11")
Sheets("saldo").Range("d10") = "SALDO INICIAL AL: " & Range("c10")

'Por último calcula el saldo en cada celda
  Dim filsaldito As String
  Dim filfecha As String
  Dim saldito As Single
      
   filfecha = 11
   filsaldito = 10
     
    'Recorre todas las filas de la hoja saldo mientras no este vacia
   
   While Sheets("saldo").Cells(filfecha, 3) <> Empty
  
    Sheets("saldo").Cells(filfecha, 7).Value = Sheets("saldo").Cells(filsaldito, 7).Value + Sheets("saldo").Cells(filfecha, 6).Value - Sheets("saldo").Cells(filfecha, 5).Value
   
    filfecha = filfecha + 1
    filsaldito = filsaldito + 1
   
   Wend

 'Este procedimiento hace colocar el saldo en la celda f6 a modo resumen
 
  Sheets("saldo").Cells(7, 6).Value = Sheets("saldo").Cells(filsaldito, 7).Value + Sheets("saldo").Cells(filfecha, 6).Value - Sheets("saldo").Cells(filfecha, 5).Value

'ejecuta la rutina que le da formato a las celdas
FormatoCeldasSaldo
'Se posiciona la vista de la hoja en la fila 7
ActiveWindow.ScrollRow = 7
'oculta el formulario en el que se ingresa el saldo a buscar
Unload Me
'Se oculta también lo hoja cancela op , porque el saldo puede ser consuldado desde ahí
'Sheets("cancela oP").Visible = xlVeryHidden
'Sheets("dbcomp").Visible = xlVeryHidden
Sheets("saldo").Protect Password:="1111"
Sheets("saldo").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    ActiveSheet.EnableSelection = xlNoSelection
Application.ScreenUpdating = True
End Sub
Private Sub CommandButton2_Click()
Unload Me
End Sub

Private Sub textbox3_AfterUpdate()
Dim quebusco As String
Dim rangoabuscar As String
Dim busca As Object
On Error Resume Next
rangoabuscar = "a2:a10000"
quebusco = TextBox3.Text
Set busca = Sheets("Proveedores").Range(rangoabuscar).Find(quebusco, LookIn:=xlValues, LookAt:=xlWhole)
If Not busca Is Nothing Then
ComboBox1 = busca.Offset(0, 1)
Else
MsgBox "No existe Proveedores o la cuenta esta mal ingresada" & Chr("saldo") & " Ingrese en formato 00000, ej. 00010, 01020", vbCritical
TextBox3.SetFocus
Exit Sub
End If
End Sub
Private Sub UserForm_Activate()
Application.ScreenUpdating = False
Sheets("proveedores").Activate
Range("b2").Select
Do While ActiveCell <> Empty
       ComboBox1.AddItem ActiveCell
       ActiveCell.Offset(1, 0).Select
Loop
End Sub



Código que se introduce en módulo

Sub muestrauserform5()
Load UserForm5
UserForm5.Show
End Sub




Si te fue de utilidad puedes INVITARME UN CAFÉ y de esta manera ayudar a seguir manteniendo la página, CLICK para descargar en ejemplo en forma gratuita.



If this post was helpful INVITE ME A COFFEE and so help keep up the page, CLICK to download free example.

Si te gustó por favor compártelo con tus amigos
If you liked please share it with your friends