Antoni

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

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

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

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

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

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

32

No me había fijado, con una dirección fija, me da error a la sexta. (Windows 10, 32 bits)

A mi ya me da error la primera vez. 🙁

Cambia ThisWorkbook.Path & "\Archivo.txt" Por la ruta exacta de tu archivo.

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

Todo esto está en la ayuda de Office, pero es más cómodo que lo busque otro. 🙁

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

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

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.