I have a program that needs to iterate through a very large excel range, to combine two ranges into one combo box value. I have the following code to do so, but all it does is iterate the first value five times. If I remove the first FOR loop, then it simply only returns the first value and never completes. Any suggestions on what I can do to polish this code up and get it working?
Dim i As Integer
If TenantBox.SelectedItem = "CNS" Then
WFMBook.Workbooks.Open("C:\Schedule.xlsx")
For i = 0 To 5 Step +1
For Each CNSCell In WFMBook.Range("A3:A1441").Cells
f = CNSCell.Value.ToString
Next
For Each tst In WFMBook.Range("B3:B1441").Cells
l = tst.Value.ToString
Next
ComboBox1.Items.Add(f + " " + l)
If (i = 5) Then
Exit For
End If
Console.WriteLine(i)
Next
End If
Try this, just change the x to 1 if VBA is 1 based.
If TenantBox.SelectedItem = "CNS" Then
WFMBook.Workbooks.Open("C:\XHSchedule.xlsx")
Dim colCount = WFMBook.Range("A3:A8").Cells.Count
For x = 1 To colCount Step +1
For Each CNSCell In WFMBook.Range("A3:A8").Cells
f = WFMBook.Range("A3:A8").Cells(x).Value.ToString
l = WFMBook.Range("B3:B8").Cells(x).Value.ToString
Next
ComboBox1.Items.Add(f + " " + l)
Next
End If
Related
Im trying to fill multiple matrices according to inputs from a userform.
Right now i have to create 5 matrices but i want this to be able to change in the future, so i want to create the variables "on the fly" in my loop. I basically want to Create Matrix1, Matrix2, Matrix3 ... Matrixn, but i can't figure how to do it. Any Ideas ?
Following you can see the script --> The two last lines are totally wrong (i know it) but i just added them in hope that you understand what i want to do :)
PS: And most important i should be able to then look to Matrix1(i,j),..., Matrixn(i,j) values easily
Looking Forward your help <3
'FicheCalcul ----------------------------------------------------------------------------------------------------
Dim Temp4 As String
Dim Temp5 As String
Dim MatrixTemp(3 - 1, 5 - 1) As Double 'm-1,x-1
For i = 1 To 5 'n
For j = 0 To 3 - 1 'm-1
For k = 0 To 5 - 1 'X-1
Temp4 = j & "C" & i
Temp5 = Temp4 & k
If UserForm1.Controls(Temp5) = False Then
MatrixTemp(j, k) = ""
Else
If UserForm1.Controls(Temp5) = True Then
MatrixTemp(j, k) = k - 2 ' -2 -1 0 1 2
End If
End If
Next k
Next j
Dim ("Matrix"&i)(3-1,5-1) As Double
("Matrix"&i) = MatrixTemp
Next i
You cannot have variable variable names. Therefore you need to use arrays.
Option Explicit
Sub example()
Dim MatrixTemp(4, 5) As Double
'do your matrix stuff here
MatrixTemp(0, 0) = 1
MatrixTemp(0, 1) = 2
MatrixTemp(0, 2) = 3
Dim Matrix(4) As Variant 'create an array of 5 matices
Matrix(0) = MatrixTemp 'fill your temp matrix into the first matrix
Debug.Print Matrix(0)(0, 2) 'outputs 3
End Sub
I am creating a third party add in for my CAD program that has a sub in it that goes through a drawing and finds all the parts lists (BOMS), if any items in the parts list are shared between the BOM (1 part being used in 2 weldments for example) then it changes the item number of the second instance to be that of the first instance. It does this by comparing full file names between the two values. When they match change the number to that of the matcher. I have got this to work but it runs a little slow because for a 100 item BOM each item is compared to 100 and thus that takes a little longer then I would like (about 60seconds to run). After thinking about it I realized I did not need to compare each item to all the items, I just needed to compare until it found a duplicate and then exit the search loop and go to the next value. Example being Item 1 does not need to compare to the rest of the 99 values because even if it does have a match in position 100 I do not want to change item 1s number to that of item 100. I want to change item 100 to that of 1(ie change the duplpicate to that of the first encountered double). For my code however I am having trouble exiting the comparison for loops which is causing me trouble. An example of the trouble is this:
I have 3 BOMs, each one shares Part X, and is numbered 1 in BOM 1, 4 in BOM 2, and 7 in BOM 3. when I run my button because I cannot get it to leave the comparison loop once it finds it first match all the Part X's ended up getting item number 7 from BOM 3 because it is the last instance. (I can get this to do what I want by stepping through my for loops backwards and thus everything ends up as the top most occurrence, but I would like to get my exit fors working because it saves me on unnecessary comparisons)
How do I go about breaking out of the nested for loops using an if conditional?
Here is my current code:
Public Sub MatchingNumberR1()
Debug.Print ThisApplication.Caption
'define active document as drawing doc. Will produce an error if its not a drawing doc
Dim oDrawDoc As DrawingDocument
Set oDrawDoc = ThisApplication.ActiveDocument
'Store all the sheets of drawing
Dim oSheets As Sheets
Set oSheets = oDrawDoc.Sheets
Dim oSheet As Sheet
'Loop through all the sheets
For Each oSheet In oSheets
Dim oPartsLists As PartsLists
Set oPartsLists = oSheet.PartsLists
'Loop through all the part lists on that sheet
Dim oPartList As PartsList
'For every parts list on the sheet
For Each oPartList In oPartsLists
For i3 = 1 To oPartList.PartsListRows.Count
'Store the Item number and file referenced in that row to compare
oItem = FindItem(oPartList)
oDescription = FindDescription(oPartList)
oDescripCheck = oPartList.PartsListRows.Item(i3).Item(oDescription).Value
oNumCheck = oPartList.PartsListRows.Item(i3).Item(oItem).Value
'Check to see if the BOM item is a virtual component if it is do not try and get the reference part
If oPartList.PartsListRows.Item(i3).ReferencedFiles.Count = 0 Then
oRefPart = " "
End If
'Check to see if the BOM item is a virtual component if it is try and get the reference part
If oPartList.PartsListRows.Item(i3).ReferencedFiles.Count > 0 Then
oRefPart = oPartList.PartsListRows.Item(i3).ReferencedFiles.Item(1).FullFileName
End If
MsgBox (" We are comparing " & oRefPart)
'''''Create a comparison loop to go through the drawing that checks the oRefPart against other BOM items and see if there is a match.'''''
'Store all the sheets of drawing
Dim oSheets2 As Sheets
Set oSheets2 = oDrawDoc.Sheets
Dim oSheet2 As Sheet
'For every sheet in the drawing
For Each oSheet2 In oSheets2
'Get all the parts list on a single sheet
Dim oPartsLists2 As PartsLists
Set oPartsLists2 = oSheet2.PartsLists
Dim oPartList2 As PartsList
'For every parts list on the sheet
For Each oPartList2 In oPartsLists2
oItem2 = FindItem(oPartList2)
oDescription2 = FindDescription(oPartList2)
'Go through all the rows of the part list
For i6 = 1 To oPartList2.PartsListRows.Count
'Check to see if the part is a not a virtual component, if not, get the relevent comparison values
If oPartList2.PartsListRows.Item(i6).ReferencedFiles.Count > 0 Then
oNumCheck2 = oPartList2.PartsListRows.Item(i6).Item(oItem2).Value
oRefPart2 = oPartList2.PartsListRows.Item(i6).ReferencedFiles.Item(1).FullFileName
'Compare the file names, if they match change the part list item number for the original to that of the match
If oRefPart = oRefPart2 Then
oPartList.PartsListRows.Item(i3).Item(1).Value = oNumCheck2
''''''''This is where I want it to exit the loop and grab the next original value'''''''
End If
'For virtual components get the following comparison values
ElseIf oPartList2.PartsListRows.Item(i6).ReferencedFiles.Count = 0 Then
oNumCheck2 = oPartList2.PartsListRows.Item(i6).Item(oItem2).Value
oDescripCheck2 = oPartList2.PartsListRows.Item(i6).Item(oDescription2).Value
'Compare the descriptions and if they match change the part list item number for the original to that of the match
If oDescripCheck = oDescripCheck2 Then
oPartList.PartsListRows.Item(i3).Item(1).Value = oNumCheck2
''''''''This is where I want it to exit the loop and grab the next original value'''''''
End If
Else
''''''''This is where if no matches were found I want it to continue going through the comparison loop'''''''
End If
Next
Next
Next
Next
Next
Next
'MsgBox ("Matching Numbers has been finished")
End Sub
For escape from nested for loop you can use GoTo and specify where.
Sub GoToTest()
Dim a, b, c As Integer
For a = 0 To 1000 Step 100
For b = 0 To 100 Step 10
For c = 0 To 10
Debug.Print vbTab & b + c
If b + c = 12 Then
GoTo nextValueForA
End If
Next
Next
nextValueForA:
Debug.Print a + b + c
Next
End Sub
Here are a few examples that demonstrate (1) breaking out of (exiting) a loop and (2) finding the values in arrays.
The intersection of 2 arrays example can be modified to meet your need to "Create a comparison loop to go through the drawing that checks the oRefPart against other BOM items and see if there is a match." Note, you may find multiple matches between 2 arrays.
Option Explicit
Option Base 0
' Example - break out of loop when condition met.
Public Sub ExitLoopExample()
Dim i As Integer, j As Integer
' let's loop 101 times
For i = 0 To 100:
j = i * 2
'Print the current loop number to the Immediate window
Debug.Print i, j
' Let's decide to break out of the loop is some
' condition is met. In this example, we exit
' the loop if j>=10. However, any condition can
' be used.
If j >= 10 Then Exit For
Next i
End Sub
' Example - break out of inner loop when condition met.
Public Sub ExitLoopExample2()
Dim i As Integer, j As Integer
For i = 1 To 5:
For j = 1 To 5
Debug.Print i, j
' if j >= 2 then, exit the inner loop.
If j >= 2 Then Exit For
Next j
Next i
End Sub
Public Sub FindItemInArrayExample():
' Find variable n in array arr.
Dim intToFind As Integer
Dim arrToSearch As Variant
Dim x, y
intToFind = 4
arrToSearch = Array(1, 2, 3, 4, 5, 6, 7, 8, 9)
x = FindItemInArray(FindMe:=intToFind, _
ArrayToSearch:=arrToSearch)
If IsEmpty(x) Then
Debug.Print intToFind; "not found in arrToSearch"
Else
Debug.Print "found "; x
End If
intToFind = 12
y = FindItemInArray(FindMe:=intToFind, _
ArrayToSearch:=arrToSearch)
If IsEmpty(y) Then
Debug.Print intToFind; "not found in arrToSearch"
Else
Debug.Print "found "; y
End If
End Sub
Public Function FindItemInArray(FindMe, ArrayToSearch As Variant):
Dim i As Integer
For i = LBound(ArrayToSearch) To UBound(ArrayToSearch)
If FindMe = ArrayToSearch(i) Then
FindItemInArray = ArrayToSearch(i)
Exit For
End If
Next i
End Function
' Create a comparison loop to go through the drawing that checks
' the oRefPart against other BOM items and see if there is a match.
Public Sub ArrayIntersectionExample():
Dim exampleArray1 As Variant, exampleArray2 As Variant
Dim arrIntersect As Variant
Dim i As Integer
' Create two sample arrays to compare
exampleArray1 = Array(1, 2, 3, 4, 5, 6, 7)
exampleArray2 = Array(2, 4, 6, 8, 10, 12, 14, 16)
' Call our ArrayIntersect function (defined below)
arrIntersect = ArrayIntersect(exampleArray1, exampleArray2)
' Print the results to the Immediate window
For i = LBound(arrIntersect) To UBound(arrIntersect)
Debug.Print "match " & i + 1, arrIntersect(i)
Next i
End Sub
Public Function ArrayIntersect(arr1 As Variant, arr2 As Variant) As Variant:
' Find items that exist in both arr1 and arr2 (intersection).
' Return the intersection as an array (Variant).
Dim arrOut() As Variant
Dim matchIndex As Long
Dim i As Long, j As Long
' no matches yet
matchIndex = -1
' begin looping through arr1
For i = LBound(arr1) To UBound(arr1)
' sub-loop for arr2 for each item in arr1
For j = LBound(arr2) To UBound(arr2)
' check for match
If arr1(i) = arr2(j) Then
' we found an item in both arrays
' increment match counter, which we'll
' use to size our output array
matchIndex = matchIndex + 1
' resize our output array to fit the
' new match
ReDim Preserve arrOut(matchIndex)
' now store the new match our output array
arrOut(matchIndex) = arr1(i)
End If
Next j
Next i
' Have the function return the output array.
ArrayIntersect = arrOut
End Function
My macro is to send emails for some clients. It sends the email only if there is a X at one of the lines of the column B, so then it sends the whole line to the client by creating a new sheet that goes attached to the client on the email.
The problem is that I need to create a loop to count all the columns that contain the letter X, because this macro is counting only the first line that contains the letter X and then the other ones don't go to the new sheet and consequently it doesn't go to the client. Everything is OK in my macro, despite of the counter. When i run it, just the first line that contains the X goes to the client, and the others don't. Can you guys help me?
Code:
LinhaInicio = 1
While Workbooks(planilha).Sheets("Boletas").Cells(LinhaInicio, 2) <> "X"
LinhaInicio = LinhaInicio + 1
Wend
LinhaFim = LinhaInicio
While Workbooks(planilha).Sheets("Boletas").Cells(LinhaFim, 2) = "X"
LinhaFim = LinhaFim + 1
Wend
LinhaFim = LinhaFim - 1
RangeInicio = Workbooks(planilha).Sheets("Boletas").Cells(LinhaInicio, 26).Address
RangeFim = Workbooks(planilha).Sheets("Boletas").Cells(LinhaFim, 34).Address
Set RangeCopiar = ActiveSheet.Range(RangeInicio, RangeFim)
Maybe Try something like this:
Dim vArr As Variant
Dim LinhaFim As Long
Sub mainLoop()
'put all values into variant array vArr
vArr = Workbooks(planilha).Sheets("Boletas").UsedRange
For i = LBound(vArr) To UBound(vArr)
If vArr(i, 2) = "X" Then
Nestedloops (i) 'initiate nested loops
i = LinhaFim 'artificially increment counter
End If
Next i
End Sub
Sub Nestedloops(LinhaIncio As Long)
With Workbooks(planilha).Sheets("Boletas")
LinhaFim = linhaInicio
While vArr(LinhaFim, 2) = "X"
LinhaFim = LinhaFim + 1
Wend
LinhaFim = LinhaFim - 1
RangeInicio = .Cells(LinhaInicio, 26).Address
RangeFim = .Cells(LinhaFim, 34).Address
Set RangeCopiar = ActiveSheet.Range(RangeInicio, RangeFim)
'email code goes here
End With
End Sub
Tim could come up with something better though might want to see what he comes up with
you wanna search the X letter to columns or rows, sorry I didn't understand what you try to say. You want to create a loop to count all the X letter for every row and column or only for every row from a column?
here is how you define an array:
Dim timelinessSheet, o As Variant
timelinessSheet = Worksheets("your_sheet_name").Range("A2:X" & Worksheets("your_sheet_name").Cells(Worksheets("your_sheet_name").Rows.Count, "B").End(xlUp).Row).Value
and then your code
dim i as long
for i=2 to ubound (timelinessSheet,1)
if timelinessSheet(i,2)= X then
Your_condition
end if
next I
I have a listbox which I set to selectmulti
I am trying to get the values of the selected items with this :
Private Sub CommandButton3_Click()
Dim lItem As Long
Dim nboc As Integer
Dim c As Integer
Range("G:G").Clear
nboc = Worksheets("BDD").Range("IQ2").Value
c = 0
For lItem = 0 To ListBox2.ListCount - 1
If ListBox2.Selected(lItem) = True Then
c = c + 1
Worksheets("Bordereau Prep").Range("G15:G" & 14 + c) = ListBox2.List(lItem)
ListBox2.Selected(lItem) = False
End If
Next
End Sub
This works as long as I have one item selected. If I have x items selected, it returns x times the first item.
Can you help me?
(I am fairly new to VBA and am trying to learn on my own)
With this line:
Worksheets("Bordereau Prep").Range("G15:G" & 14 + c) = ListBox2.List(lItem)
you override the values previously printed by this function.
In first iteration you print the value in each cell of range G15:G15 (a single cell in this case), in second iteration you print the value in each cell of range G15:G16 (so you override the value printed in first iteration) and so on.
You need to change this line like below:
Worksheets("Bordereau Prep").Range("G14").Offset(c, 0) = ListBox2.List(lItem)
Your problem is in the line:
Worksheets("Bordereau Prep").Range("G15:G" & 14 + c) = ListBox2.List(lItem)
It simply assigns the whole range to the last found value. Here is something that works for you, you may use it somehow further and change it.
Option Explicit
Sub btn()
Dim lItem As Long
Dim c As Long
Range("G:G").Clear
For lItem = 0 To Worksheets("Bordereau Prep").ListBox2.ListCount - 1
If Worksheets("Bordereau Prep").ListBox2.Selected(lItem) = True Then
c = c + 1
Worksheets("BDD").Cells(15 + c, 7) = Worksheets("Bordereau Prep").ListBox2.List(lItem)
'Worksheets("Bordereau Prep").Range("G15:G" & 14 + c) = Worksheets("Bordereau Prep").ListBox2.List(lItem)
Worksheets("Bordereau Prep").ListBox2.Selected(lItem) = False
End If
Next lItem
End Sub
Last but not least, you try not to use Integers in VBA, but longs. Enjoy it!
I have been trying to get this VBA script to work to automate a task, but I cannot get it to work.
Basically, I have a big task list in excel with multiple columns and over 1000 Rows. It contains the task, who it is assigned to, and if it is open or closed.
In column H is who it assigned to and column N is whether the task is opened or closed.
I am trying to search by last name and if it is OPEN to add one to the counter. The end goal is to get a total count of how many open tasks a person has. Also, some of the cells in column N (task status) has extra text like comments, etc. I am sure that a InStr Function to search for the one word within the Cell would work better, but I cannot figure it out...
here is my code
Sub statuscount()
Dim tasksheet As Worksheet
Dim simons_count As Integer
Set tasksheet = ThisWorkbook.Sheets("tasks")
lr = tasksheet.Cells(Rows.Count, 1).End(xlUp).Row
For x = 5 to lr
If tasksheet.Cells(x, 8) = "Simons" And tasksheet.Cells(x, 14) = "OPEN" Then
simons_count = simons_count + 1
End If
Next x
tasksheet.Range("$O$5").Value = simons_count
End Sub
Thanks for the help!
Using If/And gets tricky in VBA, you're better off nesting two if statements:
For x = 5 to lr
If tasksheet.Cells(x, 8) = "Simons" Then
If InStr(tasksheet.Cells(x, 14).Value, "OPEN") > 0 Then
simons_count = simons_count + 1
End If
End If
Next x
This is a more general function. Insert a module and past the below code in it. Than you can use the function just like any other Excel built-in function
Function LastNamecounter(lastName As String, status As String) As Long
LastNamecounter = 0
Dim tasksheet As Worksheet
Set tasksheet = ThisWorkbook.Sheets("tasks")
lr = tasksheet.Cells(Rows.Count, 1).End(xlUp).Row
For i = 5 To lr
If InStr(tasksheet.Cells(i, 8).Value, lastName) <> 0 And InStr(tasksheet.Cells(i, 14).Value, status) <> 0 Then
LastNamecounter = LastNamecounter + 1
End If
Next i
End Function