Antoni

Debes eliminar tu primer código y sustituirlo por el que te indica ikanni.

Eso depende de la configuración anti SPAM del receptor del mensaje.

Como no subas un archivo Excel con un ejemplo de lo que quieres conseguir, no vas a conseguir ayuda.

Private Sub LlenarListBox() For x = 2 To Range("A" & Rows.Count).End(xlUp).Row B = Split(Range("B" & x), "-") C = Split(Range("C" & x), "-") D = Split(Range("D" & x), "-") With ListBox1 For y = 0 To UBound(B) .AddItem Range("A" & x) .List(.ListCount - 1, 1) = B(y) .List(.ListCount - 1, 2) = C(y) .List(.ListCount - 1, 3) = D(y) Next End With Next End Sub Llama a este procedimiento para llenar el ListBox.

Sub Buscar_dato() Dim encontrado As Range '-- If [C4] = "" Then MsgBox "Introduzca un Número a buscar", vbInformation, "Número vacío" Exit Sub End If '-- [C6:C12] = "" With Sheets("BD") Set encontrado = .Columns("B").Find(What:=[C4], LookAt:=xlWhole) 'xlWhole Busca exacto If Not encontrado Is Nothing Then [C6] = .Cells(encontrado.Row, "C") 'Nombre [C8] = .Cells(encontrado.Row, "D") 'CEDULA [C10] = .Cells(encontrado.Row, "E") 'ESTACIÓN [C12] = .Cells(encontrado.Row, "F") 'BOMBERO Range("A1") = True 'Desactiva el Che

Cada vez que añadas/modifiques en la columna A, se copiarán los datos correspondientes de la hoja N1. Trabajo.1.xlsb

Directamente de la ayuda de vba: Función Array() Nada más que añadir. .

Prueba a ver si es eso. Abre el adjunto y pulsa sobre el rectángulo azul. Modelo2.xlsm

Ya casi lo tengo, pero no será hasta mañana, que aquí donde estoy ya es hora de cenar. 😉

Lo mismo pero de otra forma, suponiendo que tu rango de celdas fuera A1:B6: Do Until WorksheetFunction.CountIf(Range("A1:B6"), ">0") = 0 'Tu macro Loop

😉

Revisa el adjunto. CONTACTOS.xlsm

En la hoja: Private Sub Worksheet_Change(ByVal Target As Range) '--------------------------------- 'Inserta la imagen de la columna A '--------------------------------- If Target.Address Like "$A$*" Then InsertarImagen Target End Sub En un módulo: Sub InsertarImágenes() '-------------------------- 'Inserta todas las imágenes '-------------------------- Dim x As Long For x = 8 To Range("A" & Rows.Count).End(xlUp).Row InsertarIagen Range("A" & x) Next End Sub '------------------------------------------------------- Sub InsertarImagen(Imagen As Range): On Error Resume Next D

Si te entendido bien, esta sería la macro: Sub TraspasarVIN() With Selection .Font.Color = vbRed 'Color rojo a celda activa [L6] = "" [O6] = "" Select Case .Offset(0, 1) Case "Nuevo": [L6] = .Value Case "Antiguo": [O6] = .Value End Select End With End Sub ¡Vaya! parece que he llegado tarde. 😉

Sin el archivo no hay nada que hacer. Revisa las normas del foro, por favor.