Jump to content

Antoni

Members
  • Content Count

    9,871
  • Joined

  • Last visited

  • Days Won

    497

About Antoni

  • Rank
    Antoni

Profile information

  • Gender Array
  • Localización: Array

Converted

  • Campos Array

Recent Profile Visitors

The recent visitors block is disabled and is not being shown to other users.

  1. Deja tus macros así: Option Explicit Sub Macro1() Dim Fila As Long, H1 As Worksheet, H2 As Worksheet '-- Application.ScreenUpdating = False 'Evita el parpadeo Set H1 = Sheets("Sheet1") Set H2 = Sheets("Sheet2") '-- Fila = H2.Range("A" & Rows.Count).End(xlUp).Row + 1 H2.Range("A" & Fila) = H1.Range("B4") H2.Range("B" & Fila) = H1.Range("B5") H2.Range("C" & Fila) = H1.Range("B6") H2.Range("D" & Fila) = H1.Range("B7") H2.Range("A4:K" & Fila).Sort Key1:=H2.Columns("A") H1.Range("B4:B7").ClearContents H1.Range("B4").Select End Sub Sub Macro2() Dim Fila As Long, H1 As Worksheet, H2 As Worksheet '-- Application.ScreenUpdating = False 'Evita el parpadeo Set H1 = Sheets("Sheet1") Set H2 = Sheets("Sheet2") '-- Fila = H2.Range("F" & Rows.Count).End(xlUp).Row + 1 H2.Range("F" & Fila) = H1.Range("E4") H2.Range("G" & Fila) = H1.Range("G4") H2.Range("H" & Fila) = H1.Range("I4") H2.Range("I" & Fila) = H1.Range("E5") H2.Range("J" & Fila) = H1.Range("G5") H2.Range("K" & Fila) = H1.Range("I5") H2.Range("F4:K" & Fila).Sort Key1:=H2.Columns("F") H1.Range("E4:E5,G4:G5,I4:I5").ClearContents H1.Range("E4").Select End Sub
  2. Prueba con esta macro. Sub BuscarCoincidencias() Application.ScreenUpdating = False Range(Range("M3"), Range("M3").End(xlDown)) = "" For x1 = 3 To Range("B3").End(xlDown).Row For x2 = 3 To Range("J3").End(xlDown).Row c = 0 For y = 10 To 12 Set n = Range("B" & x1 & ":G" & x1).Find(Cells(x2, y), , , xlWhole) If Not n Is Nothing Then c = c + 1 Next If c = 3 Then Range("M" & x2) = Range("M" & x2) + 1 Next Next End Sub
  3. Sub PseudoGráfico() Dim Verde, Amarillo, Rojo, Morado '-- Application.ScreenUpdating = False Verde = Range("A2").Font.Color Amarillo = Range("B2").Font.Color Rojo = Range("C2").Font.Color Morado = Range("D2").Font.Color '-- Columns("E").Font.Name = "Stencil" Columns("E").Font.Size = 11 Columns("E").Font.Bold = True '-- For x = 2 To Range("L" & Rows.Count).End(xlUp).Row With Range("E" & x) .Value = String(100, "|") .Font.Color = Morado If Range("L" & x) > 0 Then .Characters(1, Range("L" & x)).Font.Color = Verde If Range("M" & x) > 0 Then .Characters(Range("L" & x) + 1, Range("M" & x)).Font.Color = Amarillo If Range("N" & x) > 0 Then .Characters(Range("L" & x) + Range("M" & x) + 1, Range("N" & x)).Font.Color = Rojo End With Next End Sub
  4. Había un error en la macro, la vuelvo a subir. Sub PseudoGráfico() Dim Verde, Amarillo, Rojo '-- Application.ScreenUpdating = False Verde = Range("A2").Font.Color Amarillo = Range("B2").Font.Color Rojo = Range("C2").Font.Color '-- Columns("D:D").Font.Name = "Stencil" Columns("D:D").Font.Size = 11 Columns("D:D").Font.Bold = True '-- For x = 2 To Range("L" & Rows.Count).End(xlUp).Row With Range("D" & x) .Value = String(100, "|") .Font.Color = Rojo If Range("L" & x) > 0 Then .Characters(1, Range("L" & x)).Font.Color = Verde If Range("M" & x) > 0 Then .Characters(Range("L" & x) + 1, Range("M" & x)).Font.Color = Amarillo End With Next End Sub
  5. Esta macro hace lo que pides: Sub PseudoGráfico() Dim Verde, Amarillo, Rojo '-- Application.ScreenUpdating = False Verde = Range("A2").Font.Color Amarillo = Range("B2").Font.Color Rojo = Range("C2").Font.Color '-- Columns("D:D").Font.Name = "Stencil" Columns("D:D").Font.Size = 11 Columns("D:D").Font.Bold = True '-- For x = 2 To Range("L" & Rows.Count).End(xlUp).Row With Range("D" & x) .Value = String(100, "|") .Font.Color = Rojo .Characters(1, Range("L" & x)).Font.Color = Verde .Characters(Range("L" & x) + 1, Range("M" & x)).Font.Color = Amarillo End With Next End Sub
  6. Suponiendo que quieras cambiar el color de 3 formas con los nombres PERA, NARANJA y MANZANA: ActiveSheet.Shapes.Range(Array("PERA", "NARANJA", "MANZANA")).Select Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 0, 0) ActiveCell.Select
  7. No me había fijado, con una dirección fija, me da error a la sexta. (Windows 10, 32 bits)
  8. Cambia ThisWorkbook.Path & "\Archivo.txt" Por la ruta exacta de tu archivo.
  9. A grandes males, grandes remedios, una de las soluciones consite en poner un label transparente que ocupe todo el formulario, eso si, tendrás que detectar los click de los botones por la posición del cursor al hacer click sobre el label. Te dejo un ejemplo con el botón Salir (Image6) solucionado. He quitado el fondo del formulario para poder subir el archivo. Menú.xlsm
  10. Todo esto está en la ayuda de Office, pero es más cómodo que lo busque otro. 🙁
  11. Esta macro hace lo que pides, o eso creo. Se supone que tus datos estén en el rango A:B y tienen una fila de encabezamieno. Sub CrearArchivoTXT() Dim Cuenta, Saldo, Signo, Valor, x '-- Open ThisWorkbook.Path & "\Archivo.txt" For Output As #1 For x = 2 To Range("A" & Rows.Count).End(xlUp).Row Cuenta = CStr(Range("A" & x)) Cuenta = Cuenta & String(12 - Len(Cuenta), " ") Signo = "0" Valor = Range("B" & x) If Valor < 0 Then Signo = "N" Valor = Valor * -1 End If Saldo = Signo & Replace(Format(Valor, "00000000.00"), _ Application.DecimalSeparator, "") Print #1, Cuenta & Saldo Next Close #1 End Sub
  12. Hasta donde yo se, no existe la posibilidad de cargar una tabla de forma directa desde un listbox sin un bucle. Sería algo así (No está probado) Private Sub procesar_Click() 'Debe existir una conexión abierta de la BD con el nombre Conexion Set rs = New ADODB.Recordset With rs .CursorLocation = adUseClient .CursorType = adOpenStatic .LockType = adLockOptimistic End With '.. With ListBox1 For X = 0 To .listcount1 - 1 Sql = "INSERT INTO Entradas Values(" Sql = Sql & "'" & .List(X, 1) & "'," Sql = Sql & "'" & .List(X, 2) & "'," Sql = Sql & CLng(.List(X, 0)) & "," Sql = Sql & CCur(.List(X, 3)) & "," Sql = Sql & CCur(.List(X, 4)) & ")" rs.Open Sql, Conexion Next End With '.. rs.Close Set rs = Nothing End Sub
  13. Después de tres días todo a vuelto a la normalidad. ¿Motivo?, ni idea, supongo que va en la linea de lo comentado por Riddle. Gracias a ambos por vuestro interés.
×
×
  • Create New...

Important Information

Privacy Policy

Ayuda Excel - Madrid, Madrid, ES - Valorada por 5112 personas - Aprender Excel - Total: 4.7 / 5