I created this code in VBA so that every time I delete a number or the cell is empty(D7:O36), this code will run automatically(on selection change).
The code runs fine if a certain small amount of cells(~100) gets empty at once, then the cells will get filled with a "-".
The problem is that after doing it all at once more that around 100 times(each cell), Excel will stop working with error of run time error 1004. I've read about the error but it doesn't look like it applies here, at least not to the naked eye.
I don't know if the problem is how I implemented it or that i'm doing something too heavy for excel to handle.
UPDATE:
Thanks to - Tim Williams - comment bellow, the issue was not only fixed(for some reason it worked) but the code got super small and simple, AND it runs faster AND each time the "-" is added, Excel doesn't pull you to the active cell(you can activate other cell meanwhile the code is running)
Comment:
Maybe simpler: Dim c As Range: For Each c In Me.Range("D7:O36").Cells: If Len(c.Value)=0 Then c.Formula = "=""-""": Next c –
Tim Williams
Here is the updated code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim c As Range
For Each c In Me.Range("D7:O36").Cells
If c.Value = "" Then
c.Formula = "-":
End If
Next c
End Sub
Original code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim num As Integer
Dim letter As String
Dim count As Integer
Dim cellvalue As String
Dim cellnum As String
letter = "D"
num = 7
count = 0
For i = 0 To 432
cellnum = letter & num
cellvalue = Range(cellnum).Value
If cellvalue = "" Then
Range(cellnum).Select
ActiveCell.FormulaR1C1 = "-"
End If
If num = 36 Then
If count = 0 Then
letter = "E"
ElseIf count = 1 Then
letter = "F"
ElseIf count = 2 Then
letter = "G"
ElseIf count = 3 Then
letter = "H"
ElseIf count = 4 Then
letter = "I"
ElseIf count = 5 Then
letter = "J"
ElseIf count = 6 Then
letter = "K"
ElseIf count = 7 Then
letter = "L"
ElseIf count = 8 Then
letter = "M"
ElseIf count = 9 Then
letter = "N"
ElseIf count = 10 Then
letter = "O"
End If
num = 6
count = count + 1
End If
num = num + 1
Next i
End Sub
Related
The following code I have Will paste a value code of "01" to a cell and then skip 4 rows continuously, until reaching the end of count within the for loop. I want to run a similar loop for "02", but rather than "Step" (skip) 4 rows, I would like it to insert the value in 6 consecutive rows within the same column and then skip 3 rows continuously until reaching the end of count. I am 2 weeks new to vba, so I hope I am explaining this correctly.
Dim i As Long
If Sheet3.Range("C22").Value = "01" Then
For i = 3 To 202 Step 4
ActiveWorkbook.Sheets("CrewEntries").Cells(i, 6).Value = _
ActiveWorkbook.Sheets("MonData").Cells(22, 5).Value
Next i
ElseIf Sheet3.Range("C22").Value = "02" Then
For i = 3 To 152
ActiveWorkbook.Sheets("CrewEntries").Cells(i, 6).Value = _
ActiveWorkbook.Sheets("MonData").Cells(22, 5).Value
Next i
End If
Maybe like this:
Dim i As Long, v
v = ActiveWorkbook.Sheets("MonData").Cells(22, 5).Value
If Sheet3.Range("C22").Value = "01" Then
For i = 3 To 202 Step 4
ActiveWorkbook.Sheets("CrewEntries").Cells(i, 6).Value = v
Next i
ElseIf Sheet3.Range("C22").Value = "02" Then
For i = 3 To 152 Step 9 '6 filled + 3 empty = 9
ActiveWorkbook.Sheets("CrewEntries").Cells(i, 6).Value = v
Next i
End If
For such a kind of question, I would advise a while-loop, as in this piece of pseudo-code:
dim condition as boolean
dim loop_step, interesting_value as integer
condition = true
loop_step = 1 'just in order to be sure that it never is 0, this might create an infinite loop
interesting_value = 0 ' or some other initialisation value
while condition do
if <some_first_condition>
then
do_first_thing(interesting_value, ...)
loop_step = 3
else
do_second_thing(interesting_value, ...)
loop_step = 6
end if
interesting_value = interesting_value + loop_step
if <some_other_condition> then condition = false
Wend
Sub EarningCode()
Dim CpID As String
Dim i As Long
Dim p As Long
CpID = ActiveWorkbook.Sheets("MonData").Cells(22, 3).Value
For i = 3 To 452
If p = 9 Then
p = 1
Else
p = p + 1
End If
If p < 7 Then
ThisWorkbook.Worksheets("CrewEntries").Cells(i, 4).Value = "02"
End If
Next i
End Sub
It is really impossible to append more than 255 chars into a single cell by VBA macro in MS Excel?
Sample code:
Option Explicit
Sub TestSub()
Dim L As Long
' Const str = "1" & vbLf
Dim i As Integer
Range("A1").ClearContents
Range("A1").WrapText = True
For i = 1 To 260 ' any number greatest than 255
L = Range("A1").Characters.Count
Debug.Print L
Range("A1").Characters(L + 1, 1).Insert ("A")
Next i
End Sub
Added:
It is important to save previous formatting of chars in cell.
The following code will write 500 A into cell A1. Afterwards, every other A will be formatted bold.
Public Sub tmpSO()
For i = 1 To 500
Range("A1").Value = Range("A1").Value & "A"
Next i
For i = 1 To 500
If i Mod 2 = 0 Then Range("A1").Characters(i, 1).Font.Bold = True
Next i
End Sub
I hope that solves your problem.
Note: your code won't work because you are trying to insert a character after L + 1. Yet, your string is currently only L long and not L + 1. Once you have inserted another A you will have L + 1 characters in that cell. But not yet. So, if you are using your code with Range("A1").Characters(L, 1).Insert ("A") then it will work.
Edit#1:
The following code has been tested and correctly inserts 500 A into cell A1. Furthermore, some of the A will be formatted bold.
Sub TestSub()
Dim i As Integer
Range("A1").ClearContents
Range("A1").WrapText = True
Range("A1").Font.Bold = False
For i = 1 To 500
Range("A1").Characters(i, 1).Insert ("A")
Next i
For i = 1 To 500 Step 10
Range("A1").Characters(i, 3).Font.Bold = True
Next i
End Sub
question changed with this additional comment
https://stackoverflow.com/users/4742533/stayathome
will return and update this
initial answer
You can format the partial string using characters.
Code below appends your sample string to test string (300 characters long), then makes the last three italic, the three before that bold.
Sub LikeThis()
Dim StrIn As String
StrIn = "aaaabbbccc"
[a1] = Application.Rept("xyz", 100)
[a1].Value2 = [a1].Value2 & StrIn
[a1].Characters(Len([a1]) - 5, 3).Font.Bold = True
[a1].Characters(Len([a1]) - 2, 3).Font.Italic = True
End Sub
I have in Column K:
K8 is 6384 i.e. =SUM(J1:J8)
K9 is 2598 i.e. =SUM(J2:J9)
K10 is 12176 i.e =SUM(J3:J10)
:
:
K5488
up to K5488 (No numbers in sequence, all different numbers)
The largest number appearing in K is 1 400 000.
I need in Column M: The prime factors of each number in K
e.g. K8 is 6384 then M8 should be 2,2,2,2,3,7,19
k9 is 2598 then M9 should be 2,3,433 etc.
I found the following code by John Coleman on your site (Mar 28) which tested well, but seeing I have no programming knowledge, I don't know how to modify it to use in my columns K & M setup.
Here's the sample code:
Function Factor(ByVal n As Long, Optional FirstTrial As Long = 2) As String
Dim i As Long
Dim t As Long
Dim limit As Long
Dim rest As String
Dim s As String
If n = 1 Then
Factor = n
Exit Function
End If
limit = Int(Sqr(n))
t = FirstTrial
Do While t <= limit
If n Mod t = 0 Then
rest = Factor(n / t, t)
If rest <> "1" Then
s = t & "," & rest
End If
Factor = s
Exit Function
Else
If t = 2 Then t = 3 Else t = t + 2
End If
Loop
'if we get here:
Factor = n
End Function
Function PrimeOrFactor(n As Long) As String
Dim s As String
s = Factor(n)
If n = 1 Then
PrimeOrFactor = "Neither"
ElseIf (s) = Trim(n) Then
PrimeOrFactor = "Prime"
Else
PrimeOrFactor = s
End If
End Function
Tested like:
Sub test()
Dim i As Long
For i = 1 To 20
Cells(i, 1) = i
Cells(i, 2) = PrimeOrFactor(i)
Next i
End Sub
The function you provided is a udf (user defined function) to be used in your worksheet.
If you put the functions you provided in a normal code module, you can enter the following in your worksheet in M8:
=Factor(K8)
and copy that function down to your desired range.
Basically I have 7 cells that could be populated with text (b2, b4, b6, b8, b10, b12 and b14). I want to the code to check each of the cells to see if they have a value and send only the cells that do have a value in an email. For formatting purposes the cells pasted into the email need to have one empty cell in between and the cells need to be kept in the order they are in originally, just without the unnecessary blank cells.
I've never officially learned VBA I've only taught myself on a case by case scenario so there could be an easy solution that I'm missing. Often I can debug and find the problem but in this case Excel completely freezes and turns "Not Responding". I have a feeling that means I've got a loop somewhere unresolved but I don't really understand how. The code -seems- to run up until Range("A2").Value = Line(LineCount1). Any suggestions would be appreciated.
Public Sub SingleEmail()
Dim LineCount1 As Integer
Dim LineCount2 As Integer
Dim LineCount3 As Integer
Dim LineCount4 As Integer
Dim LineCount5 As Integer
Dim LineCount6 As Integer
Dim LineCount7 As Integer
Dim NumOfLines As Integer
Range("A2", "A14").ClearContents
LineCount1 = 2
Range("A2").Value = Line(LineCount1)
LineCount2 = 2 + LineCount1
Range("A4").Value = Line(LineCount2)
LineCount3 = 2 + LineCount2
Range("A6").Value = Line(LineCount3)
LineCount4 = 2 + LineCount3
Range("A8").Value = Line(LineCount4)
LineCount5 = 2 + LineCount4
Range("A10").Value = Line(LineCount5)
LineCount6 = 2 + LineCount5
Range("A12").Value = Line(LineCount6)
LineCount7 = 2 + LineCount6
Range("A14").Value = Line(LineCount7)
NumOfLines = Range("n3").Value
If Range("A2") <> "" Then
Range("A2", "A" & NumOfLines).Select
ActiveWorkbook.EnvelopeVisible = True
With ActiveSheet.MailEnvelope
.Introduction = ""
.Item.To = "personalemailaddress#Someplace.com"
.Item.CC = ""
.Item.Subject = "Email Subject"
.Item.send
End With
End If
End Sub
Function Line(ByRef LineCount As Integer) As String
Line = ""
Do While Line = "" Or LineCount < 13
If Range("B" & LineCount).Value <> "" Then
Line = Range("B" & LineCount).Value
Else
LineCount = LineCount + 2
End If
Loop
End Function
To answer your question:
If B4 has value and B2 is blank then this While loop become infinite. the LineCount is Stuck on 4, hence no overflow. That's why your code freezes.
Why are you running a loop in the first place. You can simply assign the values like this Range("A2:A14").Value =Range("B2:B14").Value
As per your comment, you need to use And operator in place of OR
Do While Line = "" And LineCount < 13 now the loop will exit if line <> "" or LineCount > 14
I am writing a very simple sub process to assign a letter grade to numeric grade values. I have a loop and I am trying to set the cell value to the output of my function. This seems like a very simple task but the first two iterations of my loops are not assigning any values. My Loop only goes through 4 rows.
Function get_letter(grade As Double)
Select Case grade
Case 0 To 59: letter = "F"
Case 60 To 69: letter = "D"
Case 70 To 79: letter = "C"
Case 80 To 89: letter = "B"
Case 90 To 100: letter = "A"
End Select
get_letter = letter
End Function
Sub assign_letter_grade()
Dim x As Integer
Dim grade As Range
Dim letter As Range
num_rows = Range("A2", Range("A2").End(xlDown)).Rows.Count
Set grade = Range("J2")
Set letter = Range("K2")
For x = 1 To num_rows
letter.Value = get_letter(grade.Value)
Set grade = grade.Offset(1, 0)
Set letter = letter.Offset(1, 0)
Next
End Sub
Why don't this set the values of my first two rows in the loop?
Try this:
Function get_letter(grade As Double) As String
if grade < 60 Then
get_letter = "F"
Elseif grade < 70 Then
get_letter = "D"
Elseif grade < 80 Then
get_letter = "C"
Elseif grade < 90 Then
get_letter = "B"
Else
get_letter = "A"
End If
End Function
The problem comes from the scores that is NOT included in the range. For VBA a score of 79.25 does not falls in either Case C or B. You could try to see if below would fix the problem:
Function get_letter(grade As Double)
Select Case grade
Case 0 To 59.99: letter = "F"
Case 60 To 69.99: letter = "D"
Case 70 To 79.99: letter = "C"
Case 80 To 89.99: letter = "B"
Case 90 To 100.99: letter = "A" ' assuming student can get a score over 100
End Select
get_letter = letter
End Function
Or using INDEX/MATCH
Function get_letter(grade As Double) As String
get_letter = Evaluate("INDEX({""F"",""D"",""C"",""B"",""A""},MATCH(" & grade & ",{0,60,70,80,90,100}))")
End Function
sample
Sub b()
Debug.Print get_letter(59.99)
Debug.Print get_letter(60)
End Sub
Because you start at row 2:
Set grade = Range("J2")
Set letter = Range("K2")
and then immediately offset by 1 row in your loop:
Set grade = grade.Offset(1, 0)
Set letter = letter.Offset(1, 0)
therefore missing rows 1 to 2 out and starting at Row 3. Use the x variable in your loop to correct the problem:
For x = 1 To num_rows
letter.Value = get_letter(grade.Value)
Set grade = Range("J" & x)
Set letter = Range("K" & x)
Next