Scope of Cell Object in For Loop - VBA - vba

I'm working on a bit of VBA that's intended to loop over a Schedule Builder for students made in Excel. I keep getting an Error 424 during the assignments c = c.Offset(X, 0), but only in the nested For loops. Is there a limited scope, and if so, how do I overcome it?
Below is the code:
Public Sub generateRosters()
Worksheets("Course Rosters").Cells.ClearContents
Worksheets("Course Rosters").Range("A1") = "Course"
Worksheets("Course Rosters").Range("B1") = "Room"
Dim classTitleRange As Range
Set classTitleRange = Worksheets("Master School Schedule").Range("D1:BN1")
Dim rowCount As Integer
rowCount = 2
Dim periodArr(1 To 8) As String
periodArr(1) = "A"
periodArr(2) = "B"
periodArr(3) = "C"
periodArr(4) = "D"
periodArr(5) = "E"
periodArr(6) = "F"
periodArr(7) = "G"
periodArr(8) = "Z"
For Each c In classTitleRange.Cells
Dim courseTitle As String
courseTitle = c
c = c.Offset(2, 0)
Dim room As String
room = c
For Each p In periodArr()
Dim offsetCount As Integer
offsetCount = 0
For i = 1 To 340
c = c.Offset(1, 0) '424 Error One
If c = p Then
End If
offsetCount = offsetCount + 1
Next
c = c.Offset(-offsetCount, 0) '424 Error Two
Next
Worksheets("Course Rosters").Range("A" & rowCount) = "'" & courseTitle
Worksheets("Course Rosters").Range("B" & rowCount) = room
rowCount = rowCount + 1
Next
End Sub
Thanks, for your help.
Edit: Side question, is there a way for me to create a variable that I can manipulate like c, but not be c. Basically a Dim d As (Something) followed by d = c. I can't seem to find the right object to assign to d, so that I can make it c. Thanks again.

I don't get logic and goal of your code therefore there are only some tips for you:
c=c.offset(2,0)
changes initial Range type c variable into empty or any other value.
Next you try to use, in the line with error, the same c variable as range object which is not allowed.
What you possibly need is the Set instruction in the following lines:
Set c= c.offset(2,0)
'....
Set c= c.offset(1,0)
But as I said, I don't know the complete logic therefore this is solution for the error you have but not sure if it solve all your problems.

Related

Do-While loop (VBA) not looping

so I thought this would be a simple logical problem, but for the life of me I cannot find the issue with this code block. I have checked around on Stack for a solution, but all other do/while loop problems appear to be primarily with other languages.
What I am trying to do is simply loop through an array & add a new worksheet for each element in the array that is not null. Pretty simple right? Yet for some reason it simply loops through once and thats it.
Here is the code block:
Dim repNames() As String
Dim x As Integer
x = 25
ReDim repNames(1 To x)
repNames(1) = "Ahern"
repNames(2) = "Castronovo"
repNames(3) = "Glick"
repNames(4) = "Fields"
repNames(5) = "Murphy"
repNames(6) = "Sleeter"
repNames(7) = "Vivian"
repNames(8) = "Walschot"
repNames(9) = "Wilson"
Dim i As Integer
i = 1
Do 'Loop keeps creating only 1 new sheet. Should create 9.
Worksheets.Add.Name = repNames(i)
i = i + 2
Loop While repNames(i) <> Null
I believe the problem is with this line: Loop While repNames(i) <> Null,
but obviously the logical test seems to hold up.
Any help would be hugely appreciated!
As others note, Null is not the comparison you want to make. Testing anything for equivalence with Null will return Null -- even ?Null = Null returns Null, which is why your loop is exiting early. (Note: To test for a Null, you need to use the IsNull function which returns a boolean, but that is NOT how you test for an empty string.)
In VBA, to test for a zero-length string or empty string, you can use either "" or vbNullString constant, or some people use the Len function to check for zero-length.
Rectifying that error, as originally written in your code, your logical test should abort the loop if any item is an empty string, but none of the items are empty strings (at least not in the example data you've provided) so you end up with an infinite loop which will error once i exceeds the number of items in the repNames array.
This would be probably better suited as a For Each loop.
Dim rep as Variant
For Each rep in repNames
Worksheets.Add.Name = rep
Next
If you need to skip empty values, or duplicate values, you can add that logic as needed within the loop:
For Each rep in repNames
If rep <> vbNullString 'only process non-zero-length strings
Worksheets.Add.name = rep
End If
Next
Etc.
Firstly, you should be comparing to vbNullString. This loops multiple times:
' Declare variables
Dim repNames() As String
Dim x As Integer
Dim i As Integer
' Set data
x = 25
ReDim repNames(1 To x)
repNames(1) = "Ahern"
repNames(2) = "Castronovo"
repNames(3) = "Glick"
repNames(4) = "Fields"
repNames(5) = "Murphy"
repNames(6) = "Sleeter"
repNames(7) = "Vivian"
repNames(8) = "Walschot"
repNames(9) = "Wilson"
' Loop through items
i = 1
Do
Worksheets.Add.Name = repNames(i)
i = i + 2
Loop While repNames(i) <> vbNullString
There is one more problem – why i = i + 2 ? In your question you say you wanted the loop to execute 9 times, but using i = i + 2 skips every other item. If you indeed want to loop through every item:
Do
Worksheets.Add.Name = repNames(i)
i = i + 1
Loop While repNames(i) <> vbNullString
Here you go, I have changed the loop conditional, and changed i=i+2 to i=i+1. A regular while loop would be better than a do while encase the first element is empty
Dim repNames()
Dim x As Integer
x = 25
ReDim repNames(1 To x)
repNames(1) = "Ahern"
repNames(2) = "Castronovo"
repNames(3) = "Glick"
repNames(4) = "Fields"
repNames(5) = "Murphy"
repNames(6) = "Sleeter"
repNames(7) = "Vivian"
repNames(8) = "Walschot"
repNames(9) = "Wilson"
Dim i As Integer
i = 1
Do While repNames(i) <> ""
Worksheets.Add.Name = repNames(i)
i = i + 1
Loop

VBA to find string in cell and copy to different cell

I have data that it's not in a consistent position in the cell, sometimes it has a semicolon, sometimes it is to the right or the left of the semicolon. The end result I'm looking is to have in column B all "students" (defined by not being teacher) and in Column C, all Teachers. If no student or teacher is found, then the corresponding cell should be blank.
Currently I'm doing a text to columns to separate both columns then using the following formulas to have the student and teacher separate:
=IF(SUMPRODUCT(--ISNUMBER(SEARCH({"Arts and Music","Math and Science"},A2)))>0,B2,C2)
=IF(SUMPRODUCT(--ISNUMBER(SEARCH("Teacher",A2)))>0,B2,C2)
I still have to do a manual Find and replace to remove the parenthesis and text and leave only the student/teacher name.
IS there any VBA macro that can help me to get from Column A to my expected result in columns B and C? Thank you.
You can use regular expressions to do this. See this post on how to enable them in excel.
Sub FindStrAndCopy()
Dim regEx As New RegExp
regEx.Pattern = "\s*(\w+)\s*\((.+)\)"
With Sheets(1):
Dim arr() As String
Dim val As String
Dim i As Integer, j As Integer
Dim person As String, teachOrSubject As String
Dim mat As Object
For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row:
val = Cells(i, "A").Value
arr = Split(val, ";")
For j = 0 To UBound(arr):
Set mat = regEx.Execute(arr(j))
If mat.Count = 1 Then
person = mat(0).SubMatches(0)
teachOrSubject = mat(0).SubMatches(1)
If teachOrSubject = "Teacher" Then
Cells(i, "C").Value = person
Else
Cells(i, "B").Value = person
End If
End If
Next
Next
End With
End Sub
The macro splits the string on a semicolon and stores either 1 or 2 substrings in the 'arr' array. It then does a regular expression on each one. If the string inside the parenthesis is "Teacher" then the preceding person's name is stored in column "C" otherwise it's a student and the name is stored in column "B".
I create a button that read all the registers you have on column A
then put the students on column B
then put the Teacher on column C
Check that I used "(Teacher)" to know when a teacher is in the String
I used the sheet Called "Sheet1"
And I don't use the first row because is the header row.
If you have any question please contact me.
Private Sub CommandButton1_Click()
'---------------------------------Variables-----------------------------
Dim total, i, j As Integer
'--------------Counting the number of the register in column A----------
ThisWorkbook.Sheets("Sheet1").Range("XDM1").Formula = "=COUNTA(A:A)"
total = CInt(ThisWorkbook.Sheets("Sheet1").Range("XDM1").Value)
'---------------------Creating arrays to read the rows------------------
Dim rows(0 To 1000) As String
Dim columnsA() As String
'------------Searching into the rows to find teacher or student---------
For i = 2 To total
columnsA = Split(ThisWorkbook.Sheets("Sheet1").Range("A" & i).Value, ";")
first = LBound(columnsA)
last = UBound(columnsA)
lenghtOfArray = last - first
MsgBox lenghOfArray
For j = 0 To lenghtOfArray
If InStr(columnsA(j), "(Teacher)") > 0 Then
MsgBox columnsA(j)
ThisWorkbook.Sheets("Sheet1").Range("C" & i).Value = columnsA(j)
Else
ThisWorkbook.Sheets("Sheet1").Range("B" & i).Value = columnsA(j)
End If
Next j
Next i
'--------------------------------Finishing------------------------------
End Sub

Submitchanges after a loop - only last record saved

The following code works, but it only saves the last record in the loop, and I can't figure out why. I think the Submitchanges() is in the right place, at the end of the loop. Can someone please show me what's wrong? Thanks.
Sub POPULATE_CHAIN()
Dim newChain As New CHAIN
Dim dpSTRIKE As Integer
'get list of Options Contracts
Dim lstOPT = From Z In DATA.OPTIONs, X In DATA.UDLies
Where X.UDLY_SYM = Z.UDLY_SYM
Select Z.CONTRACT, Z.STRIKE_GAP, X.UDLY_LAST
Dim dctOPT = lstOPT.ToDictionary(Function(Z) Z.CONTRACT)
For Each key In dctOPT.Keys
For COUNT = 1 To 5
dpSTRIKE = 1850 + 5 * COUNT
Dim lkup = From Z In DATA.CHAINs
Select Z
Dim RCD_EXISTS As Boolean = lkup.Any(Function(Z) Z.CONTRACT = dctOPT(key).CONTRACT And Z.P_C = "C" And Z.STRIKE = dpSTRIKE)
If RCD_EXISTS = False Then
newChain.CONTRACT = dctOPT(key).CONTRACT
newChain.P_C = "C"
newChain.STRIKE = dpSTRIKE
DATA.CHAINs.InsertOnSubmit(newChain)
Else
newChain.CONTRACT = dctOPT(key).CONTRACT
newChain.P_C = "C"
newChain.STRIKE = dpSTRIKE
End If
Next
Next
DATA.SubmitChanges()
End Sub
Dim newChain As New CHAIN
should be inside Fore Each, exactly inside second for.
Since it is declared outside the loop, it will be detached from table and attached again to table. So it will be inserted only in last row.

Excel VBA Getting a multiple selection from a listbox

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!

Unique Combinations in an array using VBA

I need a code that could give me a list of unique combinations from a set of elements in an array, something like this:
Say myArray contains [A B C]
So, the output must be:
A
B
C
A B
A C
B C
A B C
or
A B C
B C
A C
A B
A
B
C
either output is OK for me (Starts with 1 combination, followed by 2 combinations and ends with all combination OR vice versa).
The position of the letters are not critical and the order of letters within the same combination type is also not critical.
I'd found a suggestion by 'Dick Kusleika' in a thread: Creating a list of all possible unique combinations from an array (using VBA) but when I tried, it did not present me with the arrangement that I wanted.
I'd also found a suggestion by 'pgc01' in a thread: http://www.mrexcel.com/forum/excel-questions/435865-excel-visual-basic-applications-combinations-permutations.html and it gave me the arrangement that I wanted however, the combinations was not being populated in an array but it was being populated in excel cells instead, using looping for each combination.
So, I wanted the arrangement of combinations to be like what 'pgc01' suggested and being populated in an array as what 'Dick Kusleika' presented.
Anyone can help? Appreciate it.
Start from here:
Sub TestRoutine()
Dim inputt() As String, i As Long
Dim outputt As Variant
inputt = Split("A B C", " ")
outputt = Split(ListSubsets(inputt), vbCrLf)
For i = LBound(outputt) + 2 To UBound(outputt)
MsgBox i & vbTab & outputt(i)
Next i
End Sub
Function ListSubsets(Items As Variant) As String
Dim CodeVector() As Long
Dim i As Long
Dim lower As Long, upper As Long
Dim SubList As String
Dim NewSub As String
Dim done As Boolean
Dim OddStep As Boolean
OddStep = True
lower = LBound(Items)
upper = UBound(Items)
ReDim CodeVector(lower To upper) 'it starts all 0
Do Until done
'Add a new subset according to current contents
'of CodeVector
NewSub = ""
For i = lower To upper
If CodeVector(i) = 1 Then
If NewSub = "" Then
NewSub = Items(i)
Else
NewSub = NewSub & " " & Items(i)
End If
End If
Next i
If NewSub = "" Then NewSub = "{}" 'empty set
SubList = SubList & vbCrLf & NewSub
'now update code vector
If OddStep Then
'just flip first bit
CodeVector(lower) = 1 - CodeVector(lower)
Else
'first locate first 1
i = lower
Do While CodeVector(i) <> 1
i = i + 1
Loop
'done if i = upper:
If i = upper Then
done = True
Else
'if not done then flip the *next* bit:
i = i + 1
CodeVector(i) = 1 - CodeVector(i)
End If
End If
OddStep = Not OddStep 'toggles between even and odd steps
Loop
ListSubsets = SubList
End Function
Note we discard the first two elements of the output array.