I have a great problem. I have a macro that does not run since the last week and I do not know why? I'm getting always the error: "Runtime Error 9 ...."
I know there must be a problem with the renames or arrays but I do not find anything.
Could you please check this code, maybe you can find the problem.
Thanks in advance!
Regards, Krisztian
It is just a part of the big macro.
The error is in the 8th row when "k" would be = "10"
Ubound is teoretically "9" (??)
EditRow(k) = EditRow(k) + (insdels * (k - 1))
'Populate input sheet
insdels = 0
For i = 1 To UBound(EditRow)
If FAT_Blocks(i).Range_Name <> "Absent_from_BCM" Then ' only process the blocks that were present
k = FAT_Blocks(i).GPI_Block_Number 'ERROR***************************************************************************
EditRow(k) = EditRow(k) + (insdels * (k - 1))
For m = 1 To FAT_Blocks(i).Rows
If FAT_Blocks(i).Data(m, 1) <> 0 Then ' ignore rows with zero cost/revenue in year 1
If GPIsheet.Cells(EditRow(k), 2).Interior.ColorIndex <> new_CI Then
new_InsDel (1)
insdels = insdels + 1
EditRow(k) = EditRow(k) + (k - 1)
End If
If FAT_Blocks(i).Row_Title(m) Like "*One Time*" Then
y = 0
ElseIf FAT_Blocks(i).Row_Title(m) Like "*Recurring*" Then
y = 1
Else
y = 2
End If
With GPIsheet
.Range("Original_Import_Data").Offset(EditRow(k) - 1, 0).ClearContents ' clear any mung before updating
' fill the "new_CI" coloured cells on the left
.Cells(EditRow(k), 2).value = BCMid & " " & FAT_Blocks(i).Row_Title(m) ' row description
.Cells(EditRow(k), 3).value = FAT_Blocks(i).Data(m, 1) ' unit value
.Cells(EditRow(k), 4).value = change_pc(y) ' change %
.Cells(EditRow(k), 5).value = change_year(y) ' change year
.Cells(EditRow(k), 6).value = vol_driver(y) ' volume driver
' fill the grey stuff on the right
With .Range("Original_Import_Data").Offset(EditRow(k) - 1, 0)
.Cells(1, 1) = yr ' Contract length
.Cells(1, 2) = BCMid ' BCM unique id
For j = 1 To yr
.Cells(1, 2 + j) = FAT_Blocks(i).Data(m, j) ' data for corresponding year
Next
End With
End With
EditRow(k) = EditRow(k) + 1
End If
Next m
End If
Next i
Related
I am writing a code for a project that is trying to find the minimum solution to the Vertex Cover Problem: Given a graph, find the minimum number of vertices needed to cover the graph.
I am trying to write a program for a brute force search through the entire solution space. Right now, my code works by doing the following:
Example using 4 nodes:
Check Every Single Node: Solution Space: {1}, {2}, {3}, {4}
Check Every Couple of Nodes: Solution Space: {1,2}, {1,3}, {1,4}, {2,3}, {2,4}, {3,4}
Check Every Triple of Nodes: Solution Space: {1,2,3}, {1,2,4}, {2,3,4}
Check Every Quadruple of Nodes: Solution Space: {1,2,3,4}
Currently, my code works for 5 nodes. The problem is that it searches through these permutations using a fixed number of nested while loops. If I wanted to run 6 nodes, I would need to add in another While loop. I am trying to generalize the code so that the number of nodes can itself be a variable.
The code finds a solution by triggering a row of binary numbers based on the solution space above, eg if the solution being tried is {1,2,4} then the first, second, and fourth binary value will be set to equal 1 while the third is set to 0. A matrix is set up to use these inputs to determine if they cover the graph. Here is a picture further showing how this works.
Any ideas on how to generalize this to any number of nodes? Thoughts on recursion?
Also, note in the code there is a section that waits for 1 second. This is just for aesthetics, it is not serving any purpose besides making the code fun to watch.
i = 0
j = 0
k = 0
m = 0
Range("Z22").Select
While i < 5 'Checks to see if a single vertice can cover the graph.
Cells(5, 20 + i).Value = 1
Application.Wait (Now + TimeValue("0:00:1"))
If Cells(21, 13).Value = Cells(22, 26).Value Then
GoTo Line1
Else
Cells(5, 20 + i) = 0
i = i + 1
End If
Wend
i = 0
While i < 4 'Checks to see if two vertices can cover the graph
Cells(5, 20 + i).Value = 1
j = i + 1
While j < 5
Cells(5, 20 + j).Value = 1
Application.Wait (Now + TimeValue("0:00:1"))
If Cells(21, 13).Value = Cells(22, 26).Value Then
GoTo Line1
Else
Cells(5, 20 + j) = 0
j = j + 1
End If
Wend
Cells(5, 20 + i) = 0
i = i + 1
Wend
k = 0
While k < 3 'Checks to see if three vertices can cover the graph
Cells(5, 20 + k) = 1
i = k + 1
While i < 4
Cells(5, 20 + i).Value = 1
j = i + 1
While j < 5
Cells(5, 20 + j).Value = 1
Application.Wait (Now + TimeValue("0:00:1"))
If Cells(21, 13).Value = Cells(22, 26).Value Then
GoTo Line1
Else
Cells(5, 20 + j) = 0
j = j + 1
End If
Wend
Cells(5, 20 + i) = 0
i = i + 1
Wend
Cells(5, 20 + k).Value = 0
k = k + 1
Wend
While m < 2 'Checks to see if four vertices can cover the graph
Cells(5, 20 + m).Value = 1
k = m + 1
While k < 3
Cells(5, 20 + k) = 1
i = k + 1
While i < 4
Cells(5, 20 + i).Value = 1
j = i + 1
While j < 5
Cells(5, 20 + j).Value = 1
Application.Wait (Now + TimeValue("0:00:1"))
If Cells(21, 13).Value = Cells(22, 26).Value Then
GoTo Line1
Else
Cells(5, 20 + j) = 0
j = j + 1
End If
Wend
Cells(5, 20 + i) = 0
i = i + 1
Wend
Cells(5, 20 + k).Value = 0
k = k + 1
Wend
Cells(5, 20 + m).Value = 0
m = m + 1
Wend
If Cells(21, 13).Value <> Cells(22, 26).Value Then 'Final effort
Range("T5:X5") = 1
MsgBox ("It takes all five vertices.")
End If
Line1:
Application.DisplayAlerts = True
End Sub
This makes combinations for any n; does not use recursion. I've got to think if recursion would be applicable (make it simpler?)
Option Explicit
Const nnodes = 6
Dim a&(), icol&
Sub Main()
ThisWorkbook.Sheets("sheet1").Activate
Cells.Delete
Dim i&, j&
For i = 1 To nnodes ' from 1 to nnodes
ReDim a(i)
For j = 1 To i ' -- start with 1 up
a(j) = j
Next j
Cells(i, 1) = i ' show
icol = 2 ' for show
Do ' -- show combination and get next combination
Loop While doi(i)
Next i
End Sub
Function doi(i) As Boolean ' show and get next
Dim j&, s$
For j = 1 To i ' build string for show
If j > 1 Then s = s & ","
s = s & Str$(a(j))
Next j
Cells(i, icol) = "{" & s & "}" ' show
icol = icol + 1
' -- get next combination (if)
For j = i To 1 Step -1 ' check if any more
If a(j) < nnodes - i + j Then Exit For
Next j
If j < 1 Then doi = False: Exit Function ' no more
a(j) = a(j) + 1 ' build next combination
While j < i
a(j + 1) = a(j) + 1
j = j + 1
Wend
doi = True
End Function
EDIT: Changed "permutation" to "combination".
EDIT2: I kept coming back to recursion -- it does simplify the code:
Option Explicit
Dim icol& ' for showing combinations
Sub Main() ' get (non-empty) partitions of nnodes
Const nnodes = 6
Dim k&
ThisWorkbook.Sheets("sheet2").Activate
Cells.Delete
For k = 1 To nnodes ' k = 1 to n
Cells(k, 1) = k ' for showing
icol = 2
Call Comb("", 0, 1, nnodes, k) ' combinations(n,k)
Next k
End Sub
Sub Comb(s$, lens&, i&, n&, k&) ' build combination
Dim s2$, lens2&, j&
For j = i To n + lens + 1 - k '
If lens = 0 Then s2 = s Else s2 = s & ", "
s2 = s2 & j
lens2 = lens + 1
If lens2 = k Then ' got it?
Cells(k, icol) = "{" & s2 & "}" ' show combination
icol = icol + 1
Else
Call Comb(s2, lens2, j + 1, n, k) ' recurse
End If
Next j
End Sub
I've got a code that keeps on returning a run-time error 1004 - Application-defined or object-defined error. I've tried stepping through the individual parts of the worksheetfunction.countif function, and they all work fine separately.
However, when I put them together, they fail.
The code is:
s = 2
While Cells(s - 1, 1) <> vbNullString
Rows(s & ":" & s + 3).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range(Cells(s, 1), Cells(s + 3, 1)).Select
Selection.Rows.Group
Cells(s, 1) = "A"
Cells(s + 1, 1) = "B"
Cells(s + 2, 1) = "C"
Cells(s + 3, 1) = "D"
r = 3
q = vbNullString
p = vbNullString
n = s
While n < s + 5
While r <= v
M = 1
If Cells(n, 1) = "A" Then
q = 5
p = 12
ElseIf Cells(n, 1) = "B" Then
q = 18
p = 25
ElseIf Cells(n, 1) = "C" Then
q = 31
p = 38
ElseIf Cells(n, 1) = "D" Then
q = 44
p = 51
End If
While M <= u
l = vbNullString
l = WorksheetFunction.CountIf(Worksheets("IT Teams").Range(Cells(q, M), Cells(p, M)), Worksheets("Players IT").Cells(s + 4, 1))
If Not IsError(l) Then
Cells(n, r) = l
Else
Cells(n, r) = vbNullString
End If
M = M + 5
r = r + 1
Wend
Wend
n = n + 1
r = 3
Wend
s = s + 5
Wend
All variables have been declared as Variants.
Edit: for clarity. Error occurs at:
l = WorksheetFunction.CountIf(Worksheets("IT Teams").Range(Cells(q, M), Cells(p, M)), Worksheets("Players IT").Cells(s + 4, 1))
The problem is the way you declare the ranges. You should always include the sheet, otherwise you get this error, if you use more than one sheet (or if you use one, but it is not the active one).
Like this:
With ActiveSheet
While Cells(s - 1, 1) <> vbNullString
.Rows(s & ":" & s + 3).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
.Range(.Cells(s, 1), .Cells(s + 3, 1)).Select
Selection.Rows.Group
.Cells(s, 1) = "A"
.Cells(s + 1, 1) = "B"
.Cells(s + 2, 1) = "C"
.Cells(s + 3, 1) = "D"
Wend
End With
Pay attention to the dots.
In general, declare the sheets and then use them:
'Option Explicit - start using option explicit
Sub test()
Dim wksA As Worksheet
Dim wksIT As Worksheet
Set wksA = ThisWorkbook.ActiveSheet
Set wksIT = ThisWorkbook.Worksheets("IT Teams")
s = 2
While Cells(s - 1, 1) <> vbNullString
wksA.Rows(s & ":" & s + 3).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
wksA.Range(wksA.Cells(s, 1), wksA.Cells(s + 3, 1)).Select
Selection.Rows.Group
wksA.Cells(s, 1) = "A"
wksA.Cells(s + 1, 1) = "B"
wksA.Cells(s + 2, 1) = "C"
wksA.Cells(s + 3, 1) = "D"
Wend
With wksIT
While M <= u
l = vbNullString
l = WorksheetFunction.CountIf(.Range(.Cells(q, M), _
.Cells(p, M)), .Cells(s + 4, 1))
If Not IsError(l) Then
.Cells(n, r) = l
Else
.Cells(n, r) = vbNullString
End If
M = M + 5
r = r + 1
Wend
End With
End Sub
Concerning your case, I am about 80% sure, that you get the error somewhere here:
l = WorksheetFunction.CountIf(Range(Cells(q, M), Cells(p, M)), Cells(s + 4, 1))
In general, never assume which worksheet your code is operating on and explicitly define it in your code.
Concerning the place where you get the error, it should be simply like this:
Set wksA = ThisWorkbook.ActiveSheet
Set wksIT = ThisWorkbook.Worksheets("IT Teams")
Set wksPl = ThisWorkbook.Worksheets("SomePlayers")
l = WorksheetFunction.CountIf(wksIT.Range(wksIT.Cells(q, M), wksIT.Cells(p, M)), _
wksPl.Cells(s + 4, 1))
Sub blockofdatatoreport()
Dim i As Integer
Dim x As Integer
Dim y As Integer
For i = 1 To 95
actvrw = Sheet1.Range("A:A").Find(what = i, searchdirection = xlNext).Row
'searching cells top to bottom
lr = Sheet2.Range("A:A").Find(what = "*", searchdirection = xlprevious).Row + 1
'searching cells bottom to top
For x = 1 To 5
Sheet2.Cells(lr, 1).Value = Sheet1.Cells(actvrw + (x - 1), 3).Value
'looping the first five columns in sheet2
Next
For y = 1 To 4
Sheet2.Cells(lr, 5 + y).Value = Sheet1.Cells(actvrw + (y - 1), 6).Value
'looping the next four columns after the first four is done in sheet2
Next
'You can also write like this or write a loop in two lines above.
'Sheet2.Cells(lr, 1).Value = Sheet1.Cells(actvrw, 3).Value
'Sheet2.Cells(lr, 2).Value = Sheet1.Cells(actvrw + 1, 3).Value
'Sheet2.Cells(lr, 3).Value = Sheet1.Cells(actvrw + 2, 3).Value
'Sheet2.Cells(lr, 4).Value = Sheet1.Cells(actvrw + 3, 3).Value
'Sheet2.Cells(lr, 5).Value = Sheet1.Cells(actvrw + 4, 3).Value
Next
End Sub
I get error called error 13 y type mismatch, what is in the above code causing the error??
I've got a macro that I run to add lines to a table, this information comes from a sql database.
My problem is, when I step through the macro it works absolutely fine and does exactly what it's supposed to. However, when I run the macro, lines go missing.
Anyone experienced something similar/any suggestions?
Thanks in advance
Tom
Sub BOMpart()
Dim NoRow, SupRow, i, j, k, h As Integer
Application.ScreenUpdating = False
NoCol = Range("Data").Columns.Count
' Reset Data Range
Application.DisplayAlerts = False
If Range("Data").Rows.Count > 1 Or Range("Data").Cells(1, 1) <> "" Then
Range("Data").Delete
End If
If Range("Supplier").Rows.Count > 1 Or Range("Supplier").Cells(1, 1) <> "" Then
Range("Supplier").Delete
End If
If NoCol > 3 Then
For a = NoCol To 4 Step -1
Range("Data").Columns(a).Delete
Next a
End If
Application.DisplayAlerts = True
' Initiate level counter
j = 1
k = 1
' Set up Level 1 BOM
part = Application.InputBox(prompt:="Enter top level part number:")
Range("Supplier").Cells(1, 1) = part
SupRow = Range("Supplier").Rows.Count
If part = False Then
End
Else
Sheets("BOMs").ListObjects( _
"BOMs").Range. _
AutoFilter Field:=1, Criteria1:=part, Operator:=xlAnd
Range("BOMs").Columns(4).SpecialCells(12).Copy Destination:=Range("Data").Columns(1)
Range("BOMs").Columns(4).SpecialCells(12).Copy Destination:=Range("Supplier").Cells(SupRow + 1, 1)
End If
Application.Wait Now + TimeValue("00:00:05")
' Part Description and FAI
NoRow = Range("Data").Rows.Count
For i = 1 To NoRow
part = Range("Data").Cells(i, k)
Sheets("Inventory").ListObjects( _
"Inventory").Range. _
AutoFilter Field:=1, Criteria1:=part, Operator:=xlAnd
Range("Inventory").Columns(4).SpecialCells(12).Copy Destination:=Range("Data").Cells(i, k + 1)
Range("Inventory").Columns(72).SpecialCells(12).Copy Destination:=Range("Data").Cells(i, k + 2)
Next i
' Input additional Levels
Do Until Range("Data").Rows.Count = Application.CountIf(Range("Data").Columns(k), "N/A")
NoRow = Range("Data").Rows.Count
NoCol = Range("Data").Columns.Count
j = j + 1
Sheets("BOM Data").Cells(1, NoCol + 1) = "Level " & j & " Pt No:"
Sheets("BOM Data").Cells(1, NoCol + 2) = "Level " & j & " Pt Desc."
Sheets("BOM Data").Cells(1, NoCol + 3) = "Level " & j & " FAI Req"
k = k + 3
On Error Resume Next
For i = NoRow To 1 Step -1
If Range("Data").Cells(i, k - 3) <> "N/A" Then
SupRow = Range("Supplier").Rows.Count
part = Range("Data").Cells(i, k - 3)
Sheets("BOMs").ListObjects( _
"BOMs").Range. _
AutoFilter Field:=1, Criteria1:=part, Operator:=xlAnd
nopart = Range("BOMs").SpecialCells(xlVisible).Rows.Count
If nopart > 0 Then
Rows(i + 2).Resize(nopart - 1).Insert
Range("Data").Range(Cells(i, 1), Cells(i, k - 1)).Copy Destination:=Range("Data").Range(Cells(i, 1), Cells(i + nopart - 1, k - 1))
Range("BOMs").Columns(4).SpecialCells(12).Copy Destination:=Range("Data").Cells(i, k)
Range("BOMs").Columns(4).SpecialCells(12).Copy Destination:=Range("Supplier").Cells(SupRow + 1, 1)
Else
Range("Data").Cells(i, k) = "N/A"
End If
Else
Range("Data").Cells(i, k) = "N/A"
End If
nopart = 0
Next i
On Error GoTo 0
NoRow = Range("Data").Rows.Count
For i = 1 To NoRow
If Range("Data").Cells(i, k) <> "N/A" Then
part = Range("Data").Cells(i, k)
Sheets("Inventory").ListObjects( _
"Inventory").Range. _
AutoFilter Field:=1, Criteria1:=part, Operator:=xlAnd
Range("Inventory").Columns(4).SpecialCells(12).Copy Destination:=Range("Data").Cells(i, k + 1)
Range("Inventory").Columns(72).SpecialCells(12).Copy Destination:=Range("Data").Cells(i, k + 2)
Else
Range("Data").Cells(i, k + 1) = "N/A"
Range("Data").Cells(i, k + 2) = "N/A"
End If
Next i
Loop
'Tidy Up
Application.DisplayAlerts = False
With Range("Data")
.Columns(NoCol + 3).Delete
.Columns(NoCol + 2).Delete
.Columns(NoCol + 1).Delete
End With
Application.DisplayAlerts = True
'Formatting
With Range("Data")
.Columns.AutoFit
End With
Sheets("Counter").Cells(1, 2) = 1
MsgBox "Done!"
Application.ScreenUpdating = True
End Sub
Firstly, you need to define the type of each variable in VBA even if they are on the same line. So right now your h variable is actually the only one defined as an integer. Not sure if this is causing your problem, but it should be fixed.
I see that in your Tidy Up section, you delete columns adjacent to the "Data" range, yet the "Data" range was potentially deleted in a previous conditional. I could see how this might cause unexpected deletes.
It would help if you tell us where the code is breaking.
Need to print a table of any numbers using VBA in excel. i.e blank row after each row . Below iswhat i wrote to print a table in consecutive rows, But i dont know how can i print the result in alternate rows?
Sub table()
a = InputBox("Enter first no")
ActiveSheet.Cells.Clear
ActiveSheet.Cells(5, 4) = "TABLE OF " & a
For i = 1 To 10
c = a * i
ActiveSheet.Cells(i + 5, 4) = a
ActiveSheet.Cells(i + 5, 5) = "*"
ActiveSheet.Cells(i + 5, 6) = i
ActiveSheet.Cells(i + 5, 7) = "="
ActiveSheet.Cells(i + 5, 8).Value = c
next i
End Sub
Sub table()
a = InputBox("Enter first no")
n As Integer
n=6
ActiveSheet.Cells.Clear
ActiveSheet.Cells(5, 4) = "TABLE OF " & a
For i = 1 To 10
c = a * i
ActiveSheet.Cells(n, 4) = a
ActiveSheet.Cells(n, 5) = "*"
ActiveSheet.Cells(n, 6) = i
ActiveSheet.Cells(n, 7) = "="
ActiveSheet.Cells(n, 8).Value = c
n = n + 2
next i
End Sub
Change your row number calculation from
i + 5
to
(i * 2) + 4