Remove emty values from a array

  • Thread starter Thread starter Guest
  • Start date Start date
G

Guest

I got a huge list of data where i have to test and remove dublicates
The list: Column A=Country, B=Institusion, C=City - all text values
List is in Range("A1:C9600")
To make this fast i use a array like : X=Range("A1:C9600")
Then i test and remove dublicate with cells(r,1)="" and so on

Problem is, when im don X array got a lot of values="" (emty)

I no I can write'em back with Range("A1:C9600")=X
and then mark all emty cells and delete rows
but i think this is too slow

Question is, how do i remove all emty "values" in X array
before i write'em back to the sheet ?

thanks in advance for any help
 
If you have data with empty rows, you can remove them in one fell swoop.
Here we delete all rows in which column C is empty:

Sub gsnu()
Dim r As Range
Set r = ActiveSheet.UsedRange.Range("C:C").SpecialCells(xlCellTypeBlanks)
r.EntireRow.Delete
End Sub
 
If your are talking about a vba array, which it sounds like you are, then of
what consequence is
Cells(r,1) = ""

since that would not do anything to the array.

You have "compress" the array so the values are contiguous.

You should do this when you a looping through the array to identify
duplicates. Just keep an index for where you are looking and a separate
index for where to move the value if you retain it. These will be the same
until after you get to the first duplicate.
 
Hi Gary, tks for reply

well thats the way im doing it now delete them all at 1 time
but even this way it takes time with about 4000 rows
so i wana do it in the array before writing to sheet

do u no a way doing that ?
 
Hi Tom, tks. for reply
Im not sure what u mean maby u can give an example, heres my code:

Sub SletDubletter()
Dim c, r, t, t2, i, rk, l, lb, lc, x
Application.Calculation = xlManual
Application.ScreenUpdating = False
Cells(1, 5) = Now()
Cells(1, 1).Select
c = ActiveCell.Column
r = Cells(65500, c).End(xlUp).Row
x = Sheets("Ark1").Range("A1:C" & r)
For t = 1 To r
If x(t, c) <> "" Then
For t2 = t + 1 To r
If x(t, c) & x(t, c + 1) & x(t, c + 2) = x(t2, c) & x(t2, c + 1) & x(t2, c +
2) Then
x(t2, c) = "": x(t2, c + 1) = "": x(t2, c + 2) = ""
End If
Next
End If
Next
Sheets("Ark2").Range("A1:C" & r) = x
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
Cells(1, 6) = Now()

End Sub
 
I just cleaned it up at the end.

Sub SletDubletter()
Dim c, r, t, t2, i, rk, l, lb, lc, x
Application.Calculation = xlManual
Application.ScreenUpdating = False
Cells(1, 5) = Now()
Cells(1, 1).Select
c = ActiveCell.Column
r = Cells(65500, c).End(xlUp).Row
x = Sheets("Ark1").Range("A1:C" & r)
For t = 1 To r
If Not IsEmpty(x(t, c)) Then
For t2 = t + 1 To r
If x(t, c) & x(t, c + 1) & x(t, c + 2) = _
x(t2, c) & x(t2, c + 1) & x(t2, c + 2) Then
x(t2, c) = Empty: x(t2, c + 1) = Empty: x(t2, c + 2) = Empty
End If
Next
End If
Next
For j = 1 To r
If IsEmpty(x(j, c)) Then
For k = j + 1 To r
If Not IsEmpty(x(k, c)) Then
For l = c To c + 2
x(j, l) = x(k, l): x(k, l) = Empty
Next
Exit For
End If
Next
End If
Next

Sheets("Ark2").Range("A1:C" & r) = x
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
Cells(1, 6) = Now()

End Sub
 
If the only non-unique values are the blanks, and if the functions in
the freely dwnloadable file at http://home.pacbell.net/beban are
available to your workbook

blanklessArray=ArrayUniques(MyArray) will produce an array without the
blanks.

Use of the function requires a reference to Microsoft Scripting Runtime.

Alan Beban
 
Back
Top