I know there are endless posts for this but as my math skills are -100 I am getting issues in calculating the correct percentage. Below I have the loop that runs and then the sub that attempt to calculate the percentage. The issue is that the width of the label is wrong and for recordset with tiny numbers as 2 all is crewed up :-)
LOOP CODE
'loop until the end of the recordset
Do While Not Glob_RecSet.EOF
'inner loop to get each record fields
For FieldCount = 0 To Glob_RecSet.Fields.Count - 1
Glob_Sheet.Range(GLobWorkSheetRange).Offset(loopCounter, FieldCount).value = Glob_RecSet.Fields(FieldCount).value
Next
'start progress bar calculations the form show and unload is called on the form code apply changes button
RunProgressBar loopCounter, TotalRows, "Runningquery for " & Glob_RecSetRunning
'Next record
Glob_RecSet.MoveNext
'advance counter
loopCounter = loopCounter + 1
Loop
SUB CODE FOR PROGRESS BAR
Public Sub RunProgressBar(loopCounter As Variant, TotalRecords As Variant, FormTitle As String)
Dim LblDonewidth As Variant
Dim ProgBarCaption As Variant
Dim ProgresPercentage As Variant
If (TotalRecords < 100) Then
TotalRecords = 100
End If
ProgresPercentage = Round(loopCounter / TotalRecords * 100, 0)
'to avoid to give the progress bar a percentage greater than 100
If (ProgresPercentage > 100) Then
ProgresPercentage = 100
End If
ProgBarCaption = Round(ProgresPercentage, 0) & "%"
FrmProgBar.Caption = FormTitle
FrmProgBar.LblDone.Width = ProgresPercentage * 2
FrmProgBar.LblText.Caption = ProgBarCaption
'The DoEvents statement is responsible for the form updating
DoEvents
End Sub
I found the asnwer; the main issue was that I was not passing the corrent total of records in the recordset; this is solved by adding the line below before opening the recordset
'Clinet-Side cursor
Glob_RecSet.CursorLocation = adUseClient
then I found this example of progress bar here from which i took the correct logic for the progress bar percentage calculation.
Below the whole code
Sub InitProgressBar(maxValue As Long)
With FrmProgBar
.LblDone.Tag = .LblRemain.Width / maxValue
.LblDone.Width = 0
.LblText.Caption = ""
End With
End Sub
Public Sub RunProgressBar(loopCounter As Variant, formTitle As String)
Dim LblDonewidth As Variant
Dim ProgBarCaption As Variant
Dim ProgresPercentage As Variant
LblDonewidth = FrmProgBar.LblDone.Tag * loopCounter
ProgresPercentage = Round(FrmProgBar.LblDone.Width / FrmProgBar.LblRemain.Width * 100, 0)
ProgBarCaption = ProgresPercentage & "%"
'to avoid to give the progress bar a percentage greater than 100
If (ProgresPercentage > 100) Then
ProgresPercentage = 100
End If
FrmProgBar.Caption = formTitle
FrmProgBar.LblDone.Width = LblDonewidth
FrmProgBar.LblText.Caption = ProgBarCaption
End Sub
which is used as follow
TotalRecords = Glob_RecSet.RecordCount
'init progressbar
InitProgressBar (TotalRecords)
'loop until the end of the recordset
Do While Not Glob_RecSet.EOF
. . . .
'The DoEvents statement is responsible for the form updating
DoEvents
'start progress bar calculations the form show and unload
'is called on the form code apply changes button
RunProgressBar loopCounter, "Runningquery for " & Glob_RecSetRunning
I am creating a spreadsheet for a client to manage his ALM. I developped it under Excel and VBA, request of my client.
One sheet "Data" calculates all the vba functions. If i calculate manually each cell all works fine, but if i run the macro it did not.
Do you have a solution? I can post the entire file if needed, for a better investigation.
At the beginning all the calculation where in excel cell, but i created dedicated function for each table, because the file was too big when saved.
Public Sub Main()
Dim i, nb_tableaux As Integer
Dim j, lignemax, BarWidth As Long
Dim ProgressPercentage As Double
Dim echeancier, nomtableau As String
Dim ws_data As Worksheet
Dim c As Range
Me.ProgressLabel.Caption = "Initialisation terminée. "
Set ws_data = Sheets("Data")
lignemax = ws_data.Range("DATA").Rows.Count
Application.ScreenUpdating = True
Application.EnableEvents = True
nb_tableaux = 17
For i = 1 To nb_tableaux
echeancier = tab_Tableaux(i, 0)
nomtableau = tab_Tableaux(i, 1)
Me.ProgressLabel.Caption = "En cours : " & echeancier
ws_data.Range(nomtableau).Calculate
'With Worksheets("Data")
For j = 1 To lignemax
For Each c In ws_data.Range(nomtableau).Rows(j)
formulaToCopy = c.Formula
c.ClearContents
c.Value = formulaToCopy
DoEvents
Next
Me.ProgressLabel.Caption = "En cours : " & echeancier & ", " & Format(j / lignemax, "0.0%") & " completed"
Me.Repaint
Next j
'End With
Me.Bar.Width = i * 200 / nb_tableaux
Me.Bar.Caption = Format(i / nb_tableaux, "0%") & " completed"
Next i
Application.ScreenUpdating = False
Application.EnableEvents = False
End Sub
after taking into account the recommandations you gave me for my previous answers, the code works better, but still not for some of the ranges.
My issue come from a wrong calculation of a argument in the fonction.
In fact, I use ligne=activecell.row - 8, to get the ligne of the range to calculate. But it works if i do it manually, as the actual cell is activated, but not when i call the function many times, as i can not activate each cell, it will be too long for the spreadsheet.
How can i get ligne calculated, with the correct address of the cell where the function is written?
I hope i am clear enough. Sorry for my English.
Public Function Taux_Mois(ByVal mMois As Range, ByVal sScenario As Range)
Dim ligne As Long
ligne = ActiveCell.row - 8
Select Case (Range("DATA[Flag]").Cells(ligne).Value = 0) Or (Range("DATA[frequence fixing]").Cells(ligne).Value = 0)
Case True
Taux_Mois = 0
Exit Function
Case False
Dim index_taux As Integer
Dim ajust As Long
index_taux = CInt(Range("DATA[Indexation ID]").Cells(ligne).Value)
If index_taux = 1 Then
ajust = 0
Else
Dim ajust1, dernierfixingt0, freqfixing As Integer
dernierfixingt0 = Range("DATA[Dernier fixing t0]").Cells(ligne).Value
freqfixing = Range("DATA[frequence fixing]").Cells(ligne).Value
ajust1 = (Int((mMois.Value - dernierfixingt0) / freqfixing) * freqfixing)
ajust = Worksheets("Market Data").Range("Taux_" & sScenario.Value).Offset(12 + dernierfixingt0 + ajust1, 1 + index_taux).Value
End If
Taux_Mois = Range("DATA[facteur taux (TVA, base)]").Cells(ligne).Value * (ajust + Range("DATA[Spread / Taux]").Cells(ligne).Value / 10000)
Exit Function
End Select
End Function
Helo guys. Could someone help me resolve my EXCEL VBA Code. I'm really having trouble on how to make my FLASHCARD appear IN ORDER from Cell A1 down to the last cell. I have this code but it only generates a RANDOM cell or value. How can I make it non random? I know that by using the code RND, it generates randomly. But how about NON RANDOM?
Here's the code:
Private Sub NextCard()
Application.ScreenUpdating = False
Dim finalTermRow As Integer
finalTermRow = Range("a60000").End(xlUp).Row
Dim possibleRow As Integer
Dim foundTerm As Boolean
foundTerm = False
Dim tries As Integer
tries = 0
Do While foundTerm = False And tries < 1000
possibleRow = Rnd() * (finalTermRow - 2) + 2
If Cells(possibleRow, 4).Value = "" Then
If possibleRow <> previousRow Then
foundTerm = True
End If
End If
tries = tries + 2
Loop
Application.ScreenUpdating = True
If tries < 1000 Then
currentRow = possibleRow
BoxQuestion.Text = Cells(currentRow, 1).Value
BoxDefinition.Text = ""
AltBox.Text = ""
Else
MsgBox ("There are no other cards to go to--you've learned everything else! Congratulations! To study all your cards again, click reset.")
End If
End Sub
Hope you could help me guys resolve this issue. Thank you.
replace:
tries = 0
Do While foundTerm = False And tries < 1000
possibleRow = Rnd() * (finalTermRow - 2) + 2
with
tries = 0
possibleRow=0
Do While foundTerm = False And tries < 1000
possibleRow = possibleRow + 1
I am making an app in visual basic with .NET Framework 4. I have to generate a list of prime numbers as per the user's input. So far, for my output if you put in 5 for the first five prime numbers you get 3 5 7 7 9 11 11. I am not sure if my number increment is in the wrong place. Thanks for any help you can give me. Also, I'm not sure how to include 2 as a prime number in my code.
Imports System.Math
Public Class Form1
Dim number, divisor, max, count As Integer
Dim IsPrime As Boolean
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
number = TextBox1.Text
For divisor = 2 To Sqrt(number)
If number Mod divisor = 0 Then
IsPrime = False
TextBox2.Text = ("Number is not prime")
Exit For
Else
TextBox2.Text = ("Number is prime")
End If
Next
End Sub
Private Sub Button2_Click(sender As Object, e As EventArgs) Handles Button2.Click
Dim Wrap As String
Wrap = Chr(13) & Chr(10)
max = TextBox3.Text
Dim count = 0
number = 2
While count <= max
IsPrime = True
For divisor = 2 To Sqrt(number)
If number Mod divisor = 0 Then
IsPrime = False
Exit For
Else
IsPrime = True
TextBox4.Text += number & Wrap
count += 1
End If
Next
number += 1
End While
End Sub
End Class
You should not use the else branch in the for loop, in this case, each time the Mod unequal to 0, you will touch the else block, take number 11 for example:
11 mod 2 <> 0, you went into the else block,
11 mod 3 <> 0, you went into the else block again!
you can divide the number by all numbers between 2 to sqrt(number), and then use isprime to check whether it is a prime like this.(I am using VBScript here)
isprime = true
for i = 2 to Int(sqr(number))
if number mod i = 0 then
isprime = false
exit for
end if
next
if isprime = true then
count = count + 1
' do something here...
end if
number = number + 1
and don't forget to truncate the square root of number.
Just to share with you this script :
Option Explicit
Dim Title,Copyright,j,fso
Dim WshShell,Affich,LogFile
Title = "Calcul Nombres Premiers"
Copyright = " (c) by Hackoo 2015"
For j = 2 to 1000
If Premier(j) = True Then
Affich = Affich & j & vbTab
End If
Next
MsgBox Affich,vbInformation,Title + Copyright
LogFile = "c:\NombresPremiers.txt"
Set fso = CreateObject("Scripting.FileSystemObject")
if fso.FileExists(LogFile) Then
fso.DeleteFile LogFile
end If
Affich = replace(Affich,vbTab,vbCrlf)
Call WriteLog(Affich,LogFile)
Set WshShell=CreateObject("wscript.shell")
WshShell.Run LogFile
'**********************************
Function Premier(Nombre)
Dim i,d
' Trois nombres ne seront pas pris en compte par le compteur,
' on s'organise pour qu'ils soient vus avant.
Select Case Nombre
Case 0
Premier = False
Exit Function
Case 1
Premier = False
Exit Function
Case 2
Premier = True
Exit Function
End Select
For i = 2 To Int(Sqr(Nombre)) + 1
d = Nombre Mod i
If d = 0 Then
Premier = False
Exit Function
End If
Next
Premier = True
End Function
'**********************************
Sub WriteLog(strText,LogFile)
Dim fs,ts
Const ForAppending = 8
Set fs = CreateObject("Scripting.FileSystemObject")
Set ts = fs.OpenTextFile(LogFile,ForAppending,True)
ts.WriteLine strText
ts.Close
End Sub
'***********************************
I have a loop that can go on for ages, although the "Enheder" worksheet only has like 10 rows, and the dataset im loadin has maybe 300 rows, it's taking a REALLY long time when I try to import.
Public Function ImportData()
Dim resultWorkbook As Workbook
Dim curWorkbook As Workbook
Dim importsheet As Worksheet
Dim debugsheet As Worksheet
Dim spgsheet As Worksheet
Dim totalposts As Integer
Dim year As String
Dim month As String
Dim week As String
Dim Hospital As String
Dim varType As String
Dim numrows As Integer
Dim Rng As Range
Dim colavg As String
Dim timer As String
Dim varKey As String
year = ImportWindow.ddYear.value
month = ImportWindow.ddMonth.value
week = "1"
varType = ImportWindow.ddType.value
Hospital = ImportWindow.txtHospital.value
Set debugsheet = ActiveWorkbook.Sheets("Data")
Set spgsheet = ActiveWorkbook.Sheets("Spørgsmål")
Set depsheet = ActiveWorkbook.Sheets("Enheder")
Set resultWorkbook = OpenWorkbook()
setResultColVars debugsheet
'set sheets
Set importsheet = resultWorkbook.Sheets("Dataset")
numrows = debugsheet.UsedRange.Rows.Count
'make sure that the enhed can be found in the importsheet, so the units can be extracted accordingly
If Not (importsheet.UsedRange.Find("afdeling") Is Nothing) Then
Dim DepColumn
Dim aCell
DepColumn = importsheet.UsedRange.Find("afdeling").column
'sort importsheet to allow meaningfull row calculations
Set aCell = importsheet.UsedRange.Columns(DepColumn)
importsheet.UsedRange.Sort Key1:=aCell, Order1:=xlAscending, Header:=xlYes
Dim tempRange As Range
Dim SecColumn
Dim secRange As Range
'find row ranges for departments
Application.ScreenUpdating = False
'**Here's the loop that will go on for aaaaaages until I decide to ctrl+pause**
For Each c In depsheet.UsedRange.Columns(1).Cells
splStr = Split(c.value, "_")
If UBound(splStr) = -1 Then
ElseIf UBound(splStr) = 0 Then
totalposts = totalposts + IterateColumns(GetRowRange(importsheet, DepColumn, splStr(0)), spgsheet, importsheet, debugsheet, year, month, week, Hospital, splStr(0), 0, varType, False)
ElseIf UBound(splStr) = 1 And Not (importsheet.UsedRange.Find("afdeling_" & splStr(0)) Is Nothing) Then
totalposts = totalposts + IterateColumns(GetRowRange(importsheet, importsheet.UsedRange.Find("afdeling_" & splStr(0)).column, splStr(1)), spgsheet, importsheet, debugsheet, year, month, week, Hospital, splStr(0), splStr(1), varType, False)
End If
Next
Application.ScreenUpdating = True
' go through columns to get total scores
totalposts = totalposts + IterateColumns(importsheet.UsedRange, spgsheet, importsheet, debugsheet, year, month, week, Hospital, 0, 0, varType, True)
resultWorkbook.Close Saved = True
ResultsWindow.lblPoster.Caption = totalposts
ImportWindow.Hide
ResultsWindow.Show
Else
MsgBox "Kunne ikke finde afdelingskolonnen. Kontroller at der er er en kolonne med navnet 'afdeling' i dit datasæt"
End If
End Function
Function GetRowRange(sheetRange, column, value) As Range
'check for a valid section column
sheetRange.AutoFilterMode = False
sheetRange.UsedRange.AutoFilter Field:=column, Criteria1:=value
Set GetRowRange = sheetRange.UsedRange.SpecialCells(xlCellTypeVisible)
sheetRange.AutoFilterMode = False
End Function
'iterates through columns of a range to get the averages based on the column headers
Function IterateColumns(varRange As Range, spgsheet, importsheet, resultsheet, year, month, week, Hospital, dep, sec, varType, sortspg As Boolean)
Dim numrows
Dim totalposts
Dim usedRng
totalposts = 0
numrows = resultsheet.UsedRange.Rows.Count
Dim insert
insert = True
If Not (varRange Is Nothing) Then
' go through columns to get scores
For i = 1 To varRange.Columns.Count
Dim tempi
tempi = numrows + totalposts + 1
Set Rng = varRange.Columns(i)
With Application.WorksheetFunction
'make sure that the values can calculate
If (.CountIf(Rng, "<3") > 0) Then
colavg = .SumIf(Rng, "<3") / .CountIf(Rng, "<3")
insert = True
Else
insert = False
End If
End With
'key is the variable
varKey = importsheet.Cells(1, i)
'only add datarow if the data matches a spg, and the datarow is not actually a department
If (sortSpgs(varKey, spgsheet, sortspg)) And (insert) And Not (InStr(key, "afdeling")) Then
resultsheet.Cells(tempi, WyearCol).value = year
resultsheet.Cells(tempi, WmonthCol).value = month
resultsheet.Cells(tempi, WweekCol).value = "1"
resultsheet.Cells(tempi, WhospCol).value = "Newport Hospital"
resultsheet.Cells(tempi, WdepCol).value = "=VLOOKUP(N" & tempi & ",Enheder!$A:$B,2,0)"
resultsheet.Cells(tempi, WsecCol).value = "=IFERROR(VLOOKUP(O" & tempi & ",Enheder!$A:$B,2,0),"" "")"
resultsheet.Cells(tempi, WdepnrCol).value = dep
resultsheet.Cells(tempi, WsecnrCol).value = dep & "_" & sec
resultsheet.Cells(tempi, WjtypeCol).value = varType
resultsheet.Cells(tempi, WspgCol).value = varKey
resultsheet.Cells(tempi, WsporgCol).value = "=VLOOKUP(H" & tempi & ",Spørgsmål!$D:$I,6,0)"
resultsheet.Cells(tempi, WtestCol).value = ""
resultsheet.Cells(tempi, Wsv1Col).value = colavg
resultsheet.Cells(tempi, Wsv2Col).value = (1 - colavg)
resultsheet.Cells(tempi, Wsv3Col).value = ""
resultsheet.Cells(tempi, WgrpCol).value = "=VLOOKUP(H" & tempi & ",Spørgsmål!$D:$I,4,0)"
totalposts = totalposts + 1
End If
Next
End If
IterateColumns = totalposts
End Function
'Function that gets the workbook for import
Function OpenWorkbook()
Dim pathString As String
Dim resultWorkbook As Workbook
pathString = Application.GetOpenFilename(fileFilter:="All Files (*.*), *.*")
' check if it's already opened
For Each wb In Workbooks
If InStr(pathString, wb.Name) > 0 Then
Set resultWorkbook = wb
Exit For
End If
Next wb
If Not found Then
Set resultWorkbook = Workbooks.Open(pathString)
End If
Set OpenWorkbook = resultWorkbook
End Function
'find column numbers for resultsheet instead of having to do this in every insert
Function setResultColVars(rsheet)
WyearCol = rsheet.UsedRange.Find("År").column
WmonthCol = rsheet.UsedRange.Find("Måned").column
WweekCol = rsheet.UsedRange.Find("Uge").column
WhospCol = rsheet.UsedRange.Find("Hospital").column
WdepCol = rsheet.UsedRange.Find("Afdeling").column
WsecCol = rsheet.UsedRange.Find("Afsnit").column
WdepnrCol = rsheet.UsedRange.Find("Afdelingsnr").column
WsecnrCol = rsheet.UsedRange.Find("Afsnitnr").column
WjtypeCol = rsheet.UsedRange.Find("Journaltype").column
WspgCol = rsheet.UsedRange.Find("spg").column
WsporgCol = rsheet.UsedRange.Find("spørgsmål").column
WtestCol = rsheet.UsedRange.Find("test").column
Wsv1Col = rsheet.UsedRange.Find("Svar 1").column
Wsv2Col = rsheet.UsedRange.Find("Svar 0").column
Wsv3Col = rsheet.UsedRange.Find("Svar 3").column
WgrpCol = rsheet.UsedRange.Find("Gruppering").column
End Function
Function sortSpgs(key, sheet, sortspg As Boolean)
If Not (sheet.UsedRange.Find(key) Is Nothing) Then
If (sortspg) Then
ResultsWindow.lstGenkendt.AddItem key
End If
sortSpgs = True
Else
If (sortspg) Then
ResultsWindow.lstUgenkendt.AddItem key
End If
sortSpgs = False
End If
End Function
Function Progress()
iProgress = iProgress + 1
Application.StatusBar = iProgress & "% Completed"
End Function
Difficult to debug without the source files.
I see the following potential problems:
GetRowRange: .UsedRange might return more columns than you expect. Check by pressing Ctrl-End in the worksheet and see where you end up
Some thing in your main routine - depsheet.UsedRange.Columns(1).Cells might just result in much more rows than expected
someRange.Value = "VLOOKUP(... will store the formula as text. You need .Formula = instead of .Value (this will not solve your long runtime but certainly avoid another bug)
In sortSpgs you add know or unknow items to a control. Not knowing if there's any event code behind these controls, disable events with Application.EnableEvents=False (ideally in the beginning of your main sub together with the .ScreenUpdating = False)
Also, set Application.Calculation = xlCalculationManual at the beginning and Application.Calculation = xlCalculationAutomatic at the end of your code
You're performing a lot of .Find - esp. in sortSpgs - this is potentially slow in large sheets, as it has to loop over quite some data, depending on the underlying range.
Generally, a few more "best practise remarks":
* Dim your variables with the correct types, same for returns of functions
* Use With obj to make the code cleaner. E.g. in setResulcolVars you could use With rsheet.UsedRange and remove this part in the following 15 or so lines
* In modules of small scope, it is okay to dim some variable with a module wide scope - esp. if you hand them over with every call. This will make your code much easier to read
Hope that helps a bit... mvh /P.
My guess is that Application.Screenupdating is the problem. You set to false inside the:
if Not (importsheet.UsedRange.Find("afdeling") Is Nothing) Then
block. So if the isn't the case then screenupdateing isn't disabled. you should move it to the beginning of the function.
you could also try to write the usedrange in an array, work with it , and write it back if needed.
code example
dim MyArr() as Variant
redim MyArray (1 to usedrange.rows.count, 1 to usedrange.columns)
MyArray=usedrange.value
'calculating with Myarray instead of ranges (faster)
usedrange.value=myarray 'writes changes back to the sheet/range
also, maybe you can use .match instead of .find, wich is faster.
with arrays you use application.match( SearchValue, Array_Name, False) 'false if for exact match
the same thing works for range.find() , becoming application.find()...
save first your master workbook under a new name before making such a big change...