hoLA pepermel1, Se ve interesante tu aplicación, aquí te pongo el código que se me ocurre, desde luego deben existir formas más elegantes pero aquí va esta:
Las condiciones son las siguientes:
1.-En las columnas A,B y C deben estar de forma ininterrumpida todos los datos, es decir, no debe haber celdas en blanco intermedias.
2.-En la hoja que publicaste cuando pasas los datos de la izquierda pones una celda con: "I: " y luego continuas, esto no lo hice sino que dentro de la misma celda se escribe la "I:" seguido de los datos, eso te lo dejo de tarea
.
3.-Dado que son muchos datos tal vez se tarde un poco la ejecución, es normal, si en algún momento quieres detener la ejecución en curso presiona ESC.
A continuación el código:
Código: Seleccionar todo
Sub estacas()
Dim total, contador1, contador2 As Integer 'SE DECLARAN VARIABLES
ActiveWorkbook.Worksheets(1).Select 'SE SELECIONA LA HOJA 1
Range("F:F").ClearContents 'SE LIMPIAN DATOS
total = Application.WorksheetFunction.Count(Range("A:A")) 'SE OBTIENE EL NÚMERO DE DATOS
contador1 = 1 'SE INICIALIZAN LOS CONTADORES
contador2 = 0
For i = 1 To total 'BUCLE QUE RECORRE TODAS LAS FILAS
If Cells(i, 1) = Cells(i + 1, 1) Then 'SE EVALÚA SI SE ENCUENTRA EN EL MISMO KILÓMETRO
If Cells(i, 3) >= 0 Then 'SE EVALÚA SI ES A LA DERECHA O CERO
If Cells(i, 3) = 0 Then 'SE EVALÚA SI ES CERO
Cells(contador1, 6) = "E: " & Cells(i, 1) & " " & Cells(i, 2)
Else 'SI NO ES CERO ES POSITIVO
Cells(contador1, 6) = Cells(i, 2) & " " & Cells(i, 3)
End If
contador1 = contador1 + 1
Else 'SI NO ES >= 0 ENTONCES ES NEGATIVO
contador2 = contador2 + 1
End If
Else 'SI NO ESTÁ EN EL MISMO KILOMETRAJE
Cells(contador1 + 1, 6) = "I: " & Cells(contador1 - contador2, 2) & " " & -Cells(contador1 - contador2, 3)
For j = 2 To contador2 'BUCLE PARA ESCRIBIR LOS NUMEROS NEGATIVOS
Cells(contador1 + j, 6) = Cells(contador1 - contador2 + 1 - j, 2) & " " & -Cells(contador1 - contador2 + 1 - j, 3)
Next j
Cells(contador1, 6) = Cells(i, 2) & " " & Cells(i, 3)
contador1 = i
contador1 = contador1 + 1
contador2 = 0
End If
Next i
End Sub
Y la hoja
TR. NATURAL KM. 60-70.xls
Saludos! Espero haya sido de ayuda
No tienes los permisos requeridos para ver los archivos adjuntos a este mensaje.