Optimizing loop for find&delete shift column

[slamet Harto]

Dear Master,

Kindly need your help to optimizing loop performance on my Vba Code.

History:
The attached file is using for Drawer on my project. The Randomize function is work well. However, when the one of lucky number is won then we need to delete these lucky numbers as shift column in reference sheet. So, there is no chance for the winner to win again. (No chance to double winner). The sample of data Lucky no in sheet "Indonesia" but the actual data are huge.

I guest, loop in this vba code will take so much PC memory and time or I don?t know exactly. I put this code in userform.

Any replies and suggestions would be highly appreciated.
Many thanks in advance.
Harto


Private Sub DataCompacter()
' Delete the winner / all lucky number as a Winner
' then compacted cells. So, there is no blank cell in the middle of data in sheet region
Dim LuckyNr As String ' current drawn number
Dim txt As String
Set DataRange = RefSheet.Range("A1").CurrentRegion
Dim STime As Single
LuckyNr = LbLuck.Caption
Dim DurTimer As Single
STime = Timer
Dim Xdat

Dim calcmode As Long
Dim ViewMode As Long
Dim myStrings As Variant
Dim FoundCell As Range
Dim i As Long
Dim sh As Worksheet

MsgBox "This action might be take several time, Just click Ok and don't action anything!!", vbOKOnly, "System Alert ..."


With Application
calcmode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With


Set sh = ActiveSheet
myStrings = Array(LuckyNr)


With sh
.Select
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
.DisplayPageBreaks = False

'search the values
With DataRange
For i = LBound(myStrings) To UBound(myStrings)
Do
Set FoundCell = DataRange.Find(What:=myStrings(i), _
After:=.Cells(.Cells.Count), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If FoundCell Is Nothing Then
Exit Do
Else
FoundCell.Delete Shift:=xlUp

End If

Loop
Next i

End With

End With

ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.Calculation = calcmode
.Calculation = xlCalculationAutomatic
End With


DurTimer = Timer - STime

'-----------------

DataRange(X).Value = DataRange(CLng(oldDat))
Xdat = Application.WorksheetFunction.CountA(DataRange)

txt = "Lucky Number / Drawn Number: " & ? & LuckyNr & ? & ?
txt = txt + "Banyaknya Data Lucky Number ini " & ? & Format(Xdat, "#,##0") & ? & ?
txt = txt + "Nomor tsb telah dihapus dari Region : " & ? & RefSheet.Name & Space(10) & ? & ? & vbCr
txt = txt + "------------------------------------------------------"
txt = txt + "Durasi proses (dalam Detik): " & ? & Format(DurTimer, "#,##0.00")


MsgBox txt, vbInformation, Judul
lbJmlDat = TblDataCount(CboSheetNm)

lbLoop1 = "": lbLoop2 = "": lbCellAddrs = "": LbLuck = "": lbIdx = ""

End Sub

[mikerickson]

I don't know if its faster, (I can't test your ActiveX on my Mac), but this deletes the cells holding the string LuckyNR from DataRange without looping.

Dim dataRange As Range
Dim LuckyNR As String
LuckyNR = "Lucky# THREE"
Set dataRange = Sheets("INDONESIA").Range("A1").CurrentRegion
With dataRange
With .Offset(0, .Columns.Count)
.FormulaR1C1 = "=IF(RC[" & -.Columns.Count & "]=" & Chr(34) & LuckyNR & Chr(34) & "," & Chr(34) & Chr(34) & ",RC[" & -.Columns.Count & "])"
.Value = .Value
On Error Resume Next
.SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
On Error GoTo 0
End With
.EntireColumn.Delete shift:=xlLeft
End With

[slamet Harto]

Dear Mike

Thank you for quick assistance.

I've tested the code given. However, there is zero value on the data. Can you suggest me how to replace it. I just worries the zero value will be become lucky number.

Thanks a bunch.
Best,
Harto

[mikerickson]

I don't understand what you mean about the 0 value.

If you could post a small example showing what you want before and after the routine is run, that would help.

[slamet Harto]

Dear Mike

Please find the attached for your reference.

I just replaced the following code with your suggestion.

With DataRange
For i = LBound(myStrings) To UBound(myStrings)
Do
Set FoundCell = DataRange.Find(What:=myStrings(i), _
After:=.Cells(.Cells.Count), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If FoundCell Is Nothing Then
Exit Do
Else
FoundCell.Delete Shift:=xlUp

End If

Loop
Next i

End With


Thank you so much
Rgds, Harto

[mikerickson]

If the 0 values are the only numbers in the worksheet, as in the sheet you posted,
ActiveSheet.Cells.SpecialCells(xlCellTypeConstants, xlNumbers).ClearContents

[slamet Harto]

Thanks Mike,

Let me try this and let you know soon.

Kind regards,
Harto

[mikerickson]

The sheets that you are posting have many (100,000+) cells filled with identical data.
While that size may reflect your working environment, its easier to see the overall picture from a much smaller representative sample.

If you have numerical data that isn't 0, the formula in the previous post can be modified to catch the 0's as well.

[slamet Harto]

Dear Mike,

you are right. I just re-format the data as text.
Then run again. However, its needed 107.90 second for deleting 1.105 data. Then, I need to restart my PC because this program has increasing PC memory (memory is low).
The actual data is around 4 mio on related sheet.

Guys,
:helpAwaiting another solution on this case.


Best Rgds, harto