slamet Harto
07-05-2008, 10:54 PM
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
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