I have done a "copy and paste" to a value after comparing the "road" number and the code number. If those two are matching, Excel VBA will copy and paste in a cell defined. I have created a loop to repeat it. But I discovered that up to 7000 my program was working properly, and when I replaced 7000 by 30000, Excel VBA displays
"Run-time error '13' Type mismatch "
after a certain time. I dont know why. Below is my program:
Private Sub assigment()
Dim road As Double
Dim code As Double
Dim i As Double
For i = 4 To 30000
For code = 2 To 22
For road = 4 To 65
If ActiveWorkbook.Sheets("assignment").Cells(i, 6)=ActiveWorkbook.Sheets("SSUSE").Cells(3, code) Then
If ActiveWorkbook.Sheets("assignment").Cells(i, 8) = ActiveWorkbook.Sheets("SSUSE").Cells(road, 1) Then
ActiveWorkbook.Sheets("SSUSE").Cells(road, code).Copy ActiveSheet.Paste Destination:=ActiveWorkbook.Sheets("assignment").Cells(i, 10)
End If
End If
Next
Next
Next
End Sub
Dim vSource as Variant, vCode as Variant, vRoad as Variant, vAssignment as Variant, vAddress as Variant
vSource = ActiveWorkbook.Sheets("assignment").Range("F4:F30000").Value
vCode = ActiveWorkbook.Sheets("SSUSE").Range("B3:V3").Value
vRoad = ActiveWorkbook.Sheets("SSUSE").Range("A4:A65").Value
vAddress = ActiveWorkbook.Sheets("SSUSE").Range("B4:V65").Value
vAssignment = ActiveWorkbook.Sheets("assignment").Range("H4:H30000").Value
For i = LBound(vSource,1) to UBound(vSource,1)
For code = LBound(vCode,2) to UBound(vCode,2)
For road = LBound(vRoad,1) to UBound(vRoad,1)
If (vSource(i,1) = vCode(1, code)) AND (vAssignment(i,1) = vRoad(road,1)) Then
ActiveWorkbook.Sheets("assignment").Cells(i+3, 10).Value = vAddress(Road,Code)
End If
Next
Next
Next
Related
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
I have a run-time error that I can't solve despite having searched deeply into many forum.
Here is the problem: I am using a Macro in a Model looking for a optimal allocation through a Goal-Seek function.
When I use it within that model (let's call it Model 1), the macro works perfectly.
However, i need to work in that model and in another one, to get data that will fill a table located in a 3rd excel file, which is then my "main file" (let's call it Model 3).
Thus, I need to call that macro located in Model 1 via an Application.run from Model 3.
And when I do so, I get a "Run-time error '1004': Reference isn't valid." which relates to the Goal-seek function that I use in Model 1.
Furthermore, if after that I come back to Model 1 and try to use the macro, I get the exact same error message while it was working before.
Here are my codes:
Model 3 (main):
Sub Test_Optim()
Dim JFMPath As String
Dim MacroPath As String
JFMPath = Sheets("Inputs").Range("D2")
MacroPath = Sheets("Inputs").Range("A3")
Workbooks.Open JFMPath
Application.Run (MacroPath)
End Sub
Model 1:
Option Explicit
Option Base 1
Sub Optimization_Alloc()
'Definitions
Dim i As Integer
Dim k As Integer
Dim IRR As Single
Dim IRRDelta As Single
Dim vIRR() As Single
Dim MinIRR As Single
Dim vPPA() As Single
Dim PPALevel As Single
Dim MinPPA As Single
Dim Position As Integer
Dim FlipYearIterations As Integer
Dim IterTF As Boolean
Dim IterStep As Single
Dim FlipYear As Integer
Dim OptFlipYear As Integer
Dim vFlipYear() As Integer
Dim xDistribution As Single
Dim OptxDistribution As Single
Dim vXDistribution() As Single
'enables goal-seek iterations, MaxIterations is the number you would wanna change
IterTF = Application.Iteration = True
IterStep = Application.MaxIterations
With Application
.Iteration = True
.MaxIterations = 500
.MaxChange = 0.0001
End With
FlipYearIterations = 10
ReDim vPPA(FlipYearIterations) As Single
ReDim vFlipYear(FlipYearIterations) As Integer
ReDim vXDistribution(FlipYearIterations) As Single
ReDim vIRR(FlipYearIterations) As Single
For i = 1 To FlipYearIterations
vFlipYear(i) = 2027 + i - 1
Next i
'Loops through different FlipYears. For every year, optimal allocation of cash/tax is calculated by goalseek.
For k = 1 To FlipYearIterations
Worksheets("As_Yr").Cells(345, 9) = vFlipYear(k) 'Optimal flip year
Worksheets("As_Yr").Cells(350, 9).GoalSeek Goal:=0, ChangingCell:=Worksheets("As_Yr").Cells(346, 9)
'Here is the Goalseek function from which I get the run-time error
xDistribution = Worksheets("As_Yr").Cells(346, 9)
PPALevel = Worksheets("Cockpit & As_Gen").Cells(48, 9)
vXDistribution(k) = xDistribution
vPPA(k) = PPALevel
vIRR(k) = Worksheets("As_Yr").Cells(348, 9)
Next k
'Determines optimal FlipYear
MinIRR = WorksheetFunction.Max(vIRR)
Position = WorksheetFunction.Match(MinIRR, vIRR, False)
OptFlipYear = vFlipYear(Position)
OptxDistribution = vXDistribution(Position)
'Prints optimal setting to Excel
Worksheets("As_Yr").Cells(345, 9) = OptFlipYear 'Optimal flip year
Worksheets("As_Yr").Cells(346, 9) = OptxDistribution 'Optimal CF distrib
'restores to the original goal-seek iterations setting
IterTF = Application.Iteration = True
IterStep = Application.MaxIterations
With Application
.MaxIterations = IterStep
.Iteration = IterTF
.MaxChange = 0.001
End With
End Sub
Is this something that one of you could help me with?
I guess it is a dummy mistake, but I can't figure that out.
Many thanks,
Alice
Public Sub addtoMA(dbPrice As Double, dbRow As Double, sh As Worksheet)
Dim s As Long 'for bitshifting the array
Const colstosave = 50
Dim rn As Range, intPrice() As Variant
deActsheet 'stop events and other annoyance
On Error GoTo catch
If dbRow = 0 Then
'MsgBox "row number missing in addtoma"
GoTo finally
End If
Set rn = sh.Range("At" & dbRow & ":cQ" & dbRow) 'the row
intPrice() = rn 'the array
' shift elements one position right- e.g. arr 99 moves to arr 100
For s = colstosave To 2 Step -1
If intPrice(1, s - 1) <> "" Then
intPrice(1, s) = intPrice(1, s - 1)
Else
intPrice(1, s) = 0
End If
Next s
intPrice(1, 1) = dbPrice 'current price
rn = intPrice() 'store the array
finally:
Set rn = Nothing
actSheet 'allow events and other annoyance
Exit Sub
catch:
'MsgBox Err.Description
Debug.Print ""
GoTo finally
End Sub
The code above runs perfectly when I call form the immediate window with:
addtoMA 5,9,sheetpointer
in integration it is called by a function that is embedded as a formula.
The parameters the are receibed are identical I double checked this.
rn.rows and rn.columns.count are exactly the same dimensions as
ubound(intprice,1) and ubound(intprice,2)
Yet every time it is called from the sheet it fails with
Application-defined or object-defined error
I could just use a database, but I cant be beaten by this.
Any ideas?
It just generates a few moving averages for a bot
I'm new to vba script. I am trying to write a function below but couldn't make it out successfully. I really appreciate any help I can get on this.
The code is:
Option Explicit
Dim status As String
Sub StartModule()
Dim index As Integer
Dim result As String
Dim a As Integer
Dim Name As Variant
Range("D4").Value = 1
Range("D5").Value = 5
Range("D6").Value = 9
Range("D7").Value = 2
Dim o: Set o = CreateObject("NAddIn.Functions")
status = ""
Do Until status = "DADA"
result = o.getRandomNumber
Name = Split(result, ",")
If Trim(Name(3)) = Trim(Range("D4").Value) Then
Range("C4").Value = "one"
End If
If Trim(Name(3)) = Trim(Range("D5").Value) Then
Range("C5").Value = "five"
End If
If Trim(Name(3)) = Trim(Range("D6").Value) Then
Range("C4").Value = "nine"
End If
If Trim(Name(3)) = Trim(Range("D7").Value) Then
Range("C7").Value = "two"
End If
Wait 1 '<~~ Wait for a second
If status = "EXIT" Then Exit Do
Loop
End Sub
Sub StopModule()
status = "EXIT"
End Sub
Private Sub Wait(ByVal nSec As Long)
nSec = nSec + Timer
While nSec > Timer
DoEvents
Wend
End Sub
This vba script is calling a getRandomNumber() which is a user defined function in dll file. It generates string of random numbers in the range(1,10); Then the thrid random number in the string is compared with cell values in excel to update cells in excel with some string values.
Bu,the problem is I am getting an error Run-time error 9: Subscript out of range at line If Trim(Name(3)) = Trim(Range("D4").Value) then.
Then the thrid random number in the string is compared with cell
values in excel to update cells in excel with some string values.
You're comparing fourth random number. Your 'Name' elements are (0),(1),(2),(3),(4),...
I suppose there is no element Name(3) as you're getting 'out of range' error.
I am iterating through rows,and looking up the first column of each row(name) using a different function for finding his marks.
For each "name" there is a particular entry in a different table("marks") which can also be blank or "-"
Sub main()
On error goto errorhandler
Dim name as string
Dim marks as double
Dim source as range
Dim runs as integer
runs = 1
Set source = Sheets("input").Range("$A$2")
i=1
Do until source.offset(i,0) = "" 'iterate through rows
name = source.offset(i,0)
marks = find(name)
do until runs * marks > 100
runs = runs + 1 'since marks is not defined;runs overflows
Loop
'a lot of code which relies on marks
errorhandler:
i = i + 1
Loop
End Sub
Function find(name as string) as double
find = application.vlookup(name,Sheets("values").Range("$A$2,$C$5"),2,0)
End function
now as i said the value in column 2 of that table can also be blank or "-" and thus results in error Runtime error 13 "Type mismatch"
i even tried putting on error statement inside the loop
VBA should normally search for error handling in the calling function i.e "main" but its not doing so
TRIED AND TESTED
Sub main()
On Error GoTo errorhandler
Dim name As String
Dim marks As Double
Dim source As Range
Set source = Sheets("input").Range("$A$2")
i = 1
Do Until source.Offset(i, 0) = "" 'iterate through rows
name = source.Offset(i, 0)
marks = find(name)
Debug.Print marks
i = i + 1
Loop
Exit Sub
errorhandler:
MsgBox Err.Description
End Sub
Function find(name As String) As Double
find = Application.WorksheetFunction.VLookup(name, Sheets("values").Range("$A$2:$C$5"), 2, False)
End Function
EDIT: Kartik, Sorry, I didn't see that you have already accepted the answer.
FOLLOWUP
actually i dont want to print any error message instead straightaway skip to the next iteration – Kartik Anand 14 secs ago
In that case you are handling error in the wrong section ;)
Try this
Sub main()
Dim name As String
Dim marks As Double
Dim source As Range
Set source = Sheets("input").Range("$A$2")
i = 1
Do Until source.Offset(i, 0) = "" 'iterate through rows
name = source.Offset(i, 0)
marks = find(name)
Debug.Print marks
i = i + 1
Loop
End Sub
Function find(name As String) As Double
On Error GoTo earlyexit
find = Application.WorksheetFunction.VLookup(name, Sheets("values").Range("$A$2:$C$5"), 2, False)
Exit Function
earlyexit:
find = 0
End Function
Add an Err.Clear after errorhandler:
Also, see the Excel help on Err.Clear which reccomends On Error Resume Next
together with If Err.Number <> 0 Then
This will produce much clearer code
Something like
Sub main()
On Error Resume Next
Dim name As String
Dim marks As Double
Dim source As Range
Set source = Sheets("input").Range("$A$2")
i = 1
Do Until source.Offset(i, 0) = "" 'iterate through rows
name = source.Offset(i, 0)
marks = Find(name)
If Err.Number <> 0 Then
Err.Clear
Else
' Your other code for non-error case here
End If
i = i + 1
Loop
End Sub