Remove emty values from a array

[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

 

[Guest]

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

 

[Tom Ogilvy]

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.

 

[Guest]

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 ?

 

[Guest]

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

 

[Tom Ogilvy]

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

 

[Guest]

Excelent job Tom

And still very fast - nice done

PM.

 

[Alan Beban]

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