Visual Basic para Aplicaciones - eliminar repetidos

Life is soft - evento anual de software empresarial
   
Vista:

eliminar repetidos

Publicado por Teresa  (1 intervención) el 02/12/2008 12:56:45
Hola , tengo problemas para hacer una rutina que tenga por ejemplo los sig.datos:
Columna A Columna B
1 100
1 150
2 120
3 50
3 60
Quisiera que me sume las cantidades de la columna B que corresponden al mismo numero en la columna A y que elimine la fila que corrsponda,y que la siguiente fila se desplace hacia arriba o sea que quede así:
1 250
2 120
3 110
Muchas Gracias.
Valora esta pregunta
Me gusta: Está pregunta es útil y esta claraNo me gusta: Está pregunta no esta clara o no es útil
0
Responder
información
Otras secciones de LWP con contenido de Visual Basic para Aplicaciones
- Código fuente de Visual Basic para Aplicaciones
- Cursos de Visual Basic para Aplicaciones
- Temas de Visual Basic para Aplicaciones
información
Códigos de Visual Basic para Aplicaciones
- Monto Escrito
- Convertir números a letras
- Metodos Numéricos

RE:eliminar repetidos

Publicado por VICTOR MR (49 intervenciones) el 02/12/2008 18:05:08
ESTO ES DE EXCEL??
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
Imágen de perfil de JuanC

RE:eliminar repetidos

Publicado por JuanC (431 intervenciones) el 02/12/2008 19:24:46
una macro es buena solución...

Option Explicit

'//By JuanC - Dic. 2008

Private Declare Function apiGetProcessHeap Lib "kernel32" Alias "GetProcessHeap" () As Long
Private Declare Function apiHeapAlloc Lib "kernel32" Alias "HeapAlloc" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function apiHeapFree Lib "kernel32" Alias "HeapFree" (ByVal hHeap As Long, ByVal dwFlags As Long, lpMem As Any) As Long
Private Declare Sub apiCopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Sub apiMemorySet Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, Source As Any, ByVal Length As Long)
Private Declare Sub apiMemoryGet Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, ByVal Source As Long, ByVal Length As Long)

Private Const HEAP_ZERO_MEMORY = &H8

Public Type MyStruct
value As String * 255
address As String * 255
End Type

Sub test()
Dim i&, x As Variant, j&, s$
Dim rng As Range, ptr&, hHeap&
Dim w As MyStruct
Dim col As New Collection

On Error Resume Next
[A1].Select
hHeap = apiGetProcessHeap()
With Selection
x = .Offset(i).value
Do While Trim(x) <> ""
w.value = .Offset(i, 1).value
w.address = .Offset(i, 1).address(0, 0)
ptr = apiHeapAlloc(hHeap, HEAP_ZERO_MEMORY, Len(w))
Call apiMemorySet(ptr, w, Len(w))
Err.Clear
col.Add ptr, CStr(x)
If Err.Number = 457 Then
ptr = CLng(col.Item(CStr(x)))
Call apiMemoryGet(w, ptr, Len(w))
Range(RTrim(CStr(w.address))).value = Range(RTrim(CStr(w.address))).value + Val(RTrim(CStr(w.value)))
If rng Is Nothing Then
Set rng = .Offset(i)
Else
Set rng = Union(rng, .Offset(i))
End If
End If
i = i + 1
x = .Offset(i).value
Loop
End With

If Not rng Is Nothing Then rng.EntireRow.Delete
hHeap = apiGetProcessHeap()
For i = 1 To col.Count
ptr = CLng(col.Item(i))
Call apiHeapFree(hHeap, 0, ptr)
Next
Set rng = Nothing
Set col = Nothing
End Sub

Saludos desde Baires, JuanC
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar

RE:eliminar repetidos

Publicado por Daivinson Coffi (3 intervenciones) el 14/12/2008 04:30:45
Hola aquí esta este código espero te sirva, aquí estamos para ayudarte, aunque el compañero JuanC ya te ayudo, coloco este código adicional:

Sub Sumatoria()
Dim vectorcolumnaA(), vectorcolumnaB(), vectorresultanteColA(), vectorresultanteColB()
Dim s As Long, fila As Long, suma As Double
fila = 1
'En este ciclo se cargan los vectores de los valores correspondientes a la columna A y columna B correspondientemente
Do While Cells(fila, 1).Value <> ""
ReDim Preserve vectorcolumnaA(fila)
ReDim Preserve vectorcolumnaB(fila)
vectorcolumnaA(fila) = Cells(fila, 1).Value
vectorcolumnaB(fila) = Cells(fila, 2)
fila = fila + 1
Loop
'En este ciclo se realiza la sumatoria de cada elemento si es igual se suman solo las veces que aparezca los valores en la columna A
For j = 1 To fila - 1
If valor <> vectorcolumnaA(j) Then
For i = 1 To fila - 1
If vectorcolumnaA(j) = vectorcolumnaA(i) Then
suma = suma + vectorcolumnaB(i)
valor = vectorcolumnaA(i)
End If
Next i
s = s + 1
ReDim Preserve vectorresultanteColA(s)
ReDim Preserve vectorresultanteColB(s)
vectorresultanteColA(s) = valor
vectorresultanteColB(s) = suma
suma = 0
End If
Next j
'En este ciclo se muestra el resultado tanto de la columna A como de la columna B
'Puedes colocar el código correspondiente para que puedas asentar los resultados en ciertas celdas
'cualquier cosa puedes avisar por el foro
For k = 1 To s
MsgBox vectorresultanteColA(k)
MsgBox vectorresultanteColB(k)
Next k
End Sub
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar