I am trying to convert a sub procedure to a function. This sub generate number based on some conditions. It's working as expected but when I try to convert it as a function, it only generate "0".
Can anyone please help? It will be great appreciated!
Here is my sub named "GenerateNumber"
Public Sub GenerateNumber()
Dim evenRange As Range
Dim oddRange As Range
Dim i As Integer
Set evenRange = Range("A2:Z2,A4:Z4,A6:Z6,A8:Z8,A10:Z10,A12:Z12,A14:Z14,A16:Z16,A18:Z18 ")
Set oddRange = Range("A1:Z1,A3:Z3,A5:Z5,A7:Z7,A9:Z9,A11:Z11,A13:Z13,A15:Z15,A17:Z17,A19:Z19")
If Not Intersect(Activecell, evenRange) Is Nothing Then
If Activecell.Interior.Color = Activecell.Offset(0, -1).Interior.Color Then
Activecell.Value = Activecell.Offset(0, -1).Value + 1
For i = 1 To Selection.Cells.Count - 1
Activecell.Offset(0, i).Value = Activecell.Value + i
Next i
Else
Activecell.Value = 1
For i = 1 To Selection.Cells.Count - 1
Activecell.Offset(0, i).Value = Activecell.Value + i
Next i
End If
'MsgBox "Active Cell In Even Range!"
Else
' MsgBox "Active Cell In Odd Range!"
If Activecell.Interior.Color = Activecell.Offset(0, 1).Interior.Color Then
Activecell.Value = Activecell.Offset(0, 1).Value + 1
For i = 1 To Selection.Cells.Count - 1
Activecell.Offset(0, -i).Value = Activecell.Value + i
Next i
Else
Activecell.Value = 1
For i = 1 To Selection.Cells.Count - 1
Activecell.Offset(0, -i).Value = Activecell.Value + i
Next i
End If
End If
End Sub
And my function code like this,
Public Function GenNumber() As Variant
Dim evenRange As Range
Dim oddRange As Range
Dim rng As Range
Dim i As Integer
Set evenRange = Range("A2:Z2,A4:Z4,A6:Z6,A8:Z8,A10:Z10,A12:Z12,A14:Z14,A16:Z16,A18:Z18 ")
Set oddRange = Range("A1:Z1,A3:Z3,A5:Z5,A7:Z7,A9:Z9,A11:Z11,A13:Z13,A15:Z15,A17:Z17,A19:Z19")
If Not Intersect(Activecell, evenRange) Is Nothing Then
If Activecell.Interior.Color = Activecell.Offset(0, -1).Interior.Color Then
Activecell.Value = Activecell.Offset(0, -1).Value + 1
For i = 1 To Selection.Cells.Count - 1
Activecell.Offset(0, i).Value = Activecell.Value + i
Next i
Else
Activecell.Value = 1
For i = 1 To Selection.Cells.Count - 1
Activecell.Offset(0, i).Value = Activecell.Value + i
Next i
End If
'MsgBox "Active Cell In Even Range!"
Else
' MsgBox "Active Cell In Odd Range!"
If Activecell.Interior.Color = Activecell.Offset(0, 1).Interior.Color Then
Activecell.Value = Activecell.Offset(0, 1).Value + 1
For i = 1 To Selection.Cells.Count - 1
Activecell.Offset(0, -i).Value = Activecell.Value + i
Next i
Else
Activecell.Value = 1
For i = 1 To Selection.Cells.Count - 1
Activecell.Offset(0, -i).Value = Activecell.Value + i
Next i
End If
End If
GenNumber = Activecell.Value
End Function
Can anyone say where is the wrong and how to solve it.
Thank you.
Related
Yeah i ve done it! But i need one thing -if activecell in column b - paste =Page1!E2
Sub FOT()
Dim rgb
ActiveCell.Offset(0, -1).Select
With ActiveCell
Set Rng = .EntireRow.Cells(2).Resize(1, .Column - 1)
.Offset(0, 1).Select
rgb = Evaluate("=SUM(" & Rng.Address & ")")
End With
If rgb < 1500001 Then
ActiveCell.Formula = "=Page1!E2"
Else
ActiveCell.Formula = "=Page1!F2"
End If
ActiveCell.Value = ActiveCell.Value
End Sub
Sub FOT()
Dim rgb
If ActiveCell.Column() = 2 Then
ActiveCell.Formula = "=Page1!E2"
Exit Sub
End If
ActiveCell.Offset(0, -1).Select
With ActiveCell
Set Rng = .EntireRow.Cells(2).Resize(1, .Column - 1)
.Offset(0, 1).Select
rgb = Evaluate("=SUM(" & Rng.Address & ")")
End With
If rgb < 1500001 Then
ActiveCell.Formula = "=Page1!E2"
Else
ActiveCell.Formula = "=Page1!F2"
End If
ActiveCell.Value = ActiveCell.Value
End Sub
I am currently facing above error when running vba as below(vba newbie here). Would you please see what is causing this error? I am using this script to parse information from a text file in excel with around 65000 rows.
When I click 'debug' , it highlighted this row
If Cells(i, 2).Value = "Type: Error" And Cells(i + 5, 2).Value = " STATUS : FAILURE" Then"
Thank you.
Sub color()
Dim i As Long
Dim j As Long
j = 0
ActiveSheet.Name = "Raw data"
sheets.Add.Name = "Error"
Range("A1:B1").Value = Array("DN", "Error details")
Worksheets("Raw data").Activate
For i = 1 To Rows.Count
If Cells(i, 2).Value = "Type: Error" And Cells(i + 5, 2).Value = " STATUS : FAILURE" Then
ActiveSheet.Cells(i, 2).Select
ActiveCell.Offset(-1, 0).Copy
Worksheets("Error").Range("A2").Offset(j, 0).PasteSpecial xlPasteAll
ActiveCell.Offset(6, 0).Copy
Worksheets("Error").Range("B2").Offset(j, 0).PasteSpecial xlPasteAll
j = j + 1
ElseIf Cells(i, 2).Value = "Type: Error" And Cells(i + 4, 2).Value = "Caused by ConnectException: Connection timed out" Then
ActiveSheet.Cells(i, 2).Select
ActiveCell.Offset(-1, 0).Copy
Worksheets("Error").Range("A2").Offset(j, 0).PasteSpecial xlPasteAll
ActiveCell.Offset(3, 0).Copy
Worksheets("Error").Range("B2").Offset(j, 0).PasteSpecial xlPasteAll
j = j + 1
End If
Next i
End Sub
As an alternative to iterating all the rows use Find and FindNext.
Option Explicit
Sub colorError()
Dim wsErr As Worksheet, wsData As Worksheet
Dim fnd As Range, first As String
Dim j As Long, x As Long, y As Long, c As Long
' data
Set wsData = ActiveSheet ' or Sheets(1)
wsData.Name = "Raw Data"
' error sheet
Set wsErr = Sheets.Add(after:=Sheets(Sheets.Count))
wsErr.Name = "Error" & Sheets.Count
wsErr.Range("A1:B1").Value2 = Array("DN", "Error details")
j = 1
Application.ScreenUpdating = False
wsData.Activate
' scan raw data column B
With wsData.Columns(2)
Set fnd = .Find("Type: Error", lookat:=xlWhole, LookIn:=xlValues, MatchCase:=False)
If Not fnd Is Nothing Then
first = fnd.Address
Do
fnd.Interior.color = vbYellow
x = 0
If Application.Trim(fnd.Offset(5)) = "STATUS : FAILURE" Then
x = 6 ' offset to copy
y = 5
c = RGB(255, 200, 200) ' pink
ElseIf Trim(fnd.Offset(4)) = _
"Caused by ConnectException: Connection timed out" Then
x = 3 ' offset to copy
y = 4
c = RGB(255, 200, 0) ' orange
End If
' copy to errors
If x > 0 Then
j = j + 1
fnd.Offset(-1).Copy wsErr.Cells(j, "A")
fnd.Offset(x).Copy wsErr.Cells(j, "B")
' color raw data
fnd.Offset(x).Interior.color = c
fnd.Offset(y).Interior.color = vbYellow
End If
Set fnd = .FindNext(fnd)
If fnd.Row + 6 > wsData.Rows.Count Then
MsgBox "Aborted at row " & fnd.Row, vbCritical, "End of Sheet"
Exit Do
End If
Loop While fnd.Address <> first
End If
End With
Application.ScreenUpdating = True
MsgBox j - 1 & " rows written to " & wsErr.Name, vbInformation
End Sub
I have a table of numbers like below in a excel sheet.
Excel Table
No1 No2 No3 No4 No5
1 190 134 190 101
10 142 117 10 151
155 12 12 12 128
154 154 154 154 154
I have a UserForm with 5 TextBoxes to display 5 unique numbers from the table.
When I click on the command button, It should pull 5 UNIQUE numbers from the above table and display it in the TextBoxes respectively.
Also, If I click on the command button again(i.e. Multiple Clicks to get more result), It should populate a different UNIQUE numbers from the table.
I used simple if else concept to achieve this but it is not working correctly.
Please assist me to achieve the result. Thank you!
I use the below code:
Private Sub btnGenerate_Click()
Dim PresentRow As Byte, PresentColumn As Byte
PresentRow = ActiveCell.Row
PresentColumn = ActiveCell.Column
If PresentRow = 5 And PresentColumn = 1 Then
Sheet1.Range("F2").Activate
ElseIf PresentRow = 5 And PresentColumn = 5 Then
Sheet1.Range("A2").Activate
End If
Select Case ActiveCell.Column
Case 1
TextBox1.Text = ActiveCell.Value
If ActiveCell.Offset(0, 1).Value <> TextBox1.Text Then
TextBox2.Text = ActiveCell.Offset(0, 1).Value
Else
TextBox2.Text = ActiveCell.Offset(1, 1).Value
End If
If ActiveCell.Offset(0, 2).Value <> TextBox2.Text Then
TextBox3.Text = ActiveCell.Offset(0, 2).Value
Else
TextBox3.Text = ActiveCell.Offset(1, 2).Value
End If
If ActiveCell.Offset(0, 3).Value <> TextBox3.Text Then
TextBox4.Text = ActiveCell.Offset(0, 3).Value
Else
TextBox4.Text = ActiveCell.Offset(1, 4).Value
End If
If ActiveCell.Offset(0, 4).Value <> TextBox4.Text Then
TextBox5.Text = ActiveCell.Offset(0, 4).Value
Else
TextBox5.Text = ActiveCell.Offset(1, 5).Value
End If
Case 5
TextBox1.Text = ActiveCell.Value
If ActiveCell.Offset(0, -1).Value <> TextBox1.Text Then
TextBox2.Text = ActiveCell.Offset(0, -1).Value
Else
TextBox2.Text = ActiveCell.Offset(1, -1).Value
End If
If ActiveCell.Offset(0, -2).Value <> TextBox2.Text Then
TextBox3.Text = ActiveCell.Offset(0, -2).Value
Else
TextBox3.Text = ActiveCell.Offset(1, -2).Value
End If
If ActiveCell.Offset(0, -3).Value <> TextBox3.Text Then
TextBox4.Text = ActiveCell.Offset(0, -3).Value
Else
TextBox4.Text = ActiveCell.Offset(1, -4).Value
End If
If ActiveCell.Offset(0, -4).Value <> TextBox4.Text Then
TextBox5.Text = ActiveCell.Offset(0, -4).Value
Else
TextBox5.Text = ActiveCell.Offset(1, -5).Value
End If
End Select
Sheet1.Activate
ActiveCell.Offset(1, 0).Select
End Sub
The following requires that Microsoft Scripting Runtime be added to the project via Tools, References.
In the worksheet code sheet:
Option Explicit
Private Sub CommandButton1_Click()
Dim txt As Long, vals As Variant, ky As Variant
Dim uniq As New Scripting.Dictionary
vals = Range("A2:E5").Value2
uniq.RemoveAll
Do While uniq.Count < 5
uniq.Item(vals(Application.RandBetween(LBound(vals, 1), UBound(vals, 1)), _
Application.RandBetween(LBound(vals, 2), UBound(vals, 2)))) = vbNullString
Loop
TextBox1 = uniq.Keys(0)
TextBox2 = uniq.Keys(1)
TextBox3 = uniq.Keys(2)
TextBox4 = uniq.Keys(3)
TextBox5 = uniq.Keys(4)
End Sub
I am new to VBA and coding in general. I am currently trying to transfer date from a multitab over to a workbook and keep getting the run time error 424: object required. Please help
Dim sheetname As String
Private Sub CommandButton2_Click()
Dim LastRow As Long
Dim sheetname As String
Select Case MultiPage1.Value
Case 0`sheetname = "Hannah"
Sheets(sheetname).Select
LastRow = Range("A" & Rows.Count).End(xlUp).Row
Range("A1").Select`enter code here`
Selection.End(xlDown).Offset(1, 0).Select
ActiveCell.Value = Date
ActiveCell.Offset(0, 1).Value = Me.RequestorHR.Value
ActiveCell.Offset(0, 2).Value = Me.CaseHR.Value
ActiveCell.Offset(0, 3).Value = Me.TypeHR.Value
ActiveCell.Offset(0, 4).Value = Me.UrgencyHR.Value
ActiveCell.Offset(0, 5).Value = Me.ReasonsHR.Value
ActiveCell.Offset(0, 6).Value = Me.DeadlineHR.Value
Clear_Click
Case 1
sheetname = "John"
Sheets(sheetname).Select
LastRow = Range("A" & Rows.Count).End(xlUp).Row
Range("A1").Select
Selection.End(xlDown).Offset(1, 0).Select
ActiveCell.Value = Date
ActiveCell.Offset(0, 1).Value = Me.RequestorJM.Value
ActiveCell.Offset(0, 2).Value = Me.CaseJM.Value
ActiveCell.Offset(0, 3).Value = Me.TypeJM.Value
ActiveCell.Offset(0, 4).Value = Me.UrgencyJM.Value
ActiveCell.Offset(0, 5).Value = Me.ReasonsJM.Value
ActiveCell.Offset(0, 6).Value = Me.DeadlineJM.Value
Clear_Click
I made some suggestions below so you have less repeating code. I added an array so you do not have to keep retyping all your textbox(Assuming) values each time. I hope that helps. I had to guess so if it needs to be tweaked let me know bud! It may run an error cause i was not sure of the active cell your referring too. If you let me know, i can fix it.
Private Sub CommandButton2_Click()
Dim LastRow As Long
Dim sheetname As String
Dim strList() As Variant
Dim i As Integer
strList = Array(, Me.RequestorHR.Value, Me.CaseHR.Value, Me.TypeHR.Value, _
Me.UrgencyHR.Value, Me.ReasonsHR.Value, Me.DeadlineHR.Value)
Select Case MultiPage1.Value
Case 0
sheetname = "Hannah"
Sheets(sheetname).Select
LastRow = Sheets(sheetname).Range("A" & Rows.Count).End(xlUp).Row
Sheets(sheetname).Range("A1").End(xlDown).Offset(1, 0).Value = Date
For i = 1 To 6
With Sheets(sheetname)
.ActiveCell.Offset(0, i).Value = strList(i)
End With
Next i
Clear_Click
Case 1
sheetname = "John"
Sheets(sheetname).Select
LastRow = Sheets(sheetname).Range("A" & Rows.Count).End(xlUp).Row
Sheets(sheetname).Range("A1").End(xlDown).Offset(1, 0).Value = Date
For i = 1 To 6
With Sheets(sheetname)
.ActiveCell.Offset(0, i).Value = strList(i)
End With
Next i
Clear_Click
In Userform Code:
' StartUpPosition > Manual
Private Sub UserForm_Initialize()
With Me
.Top = Int(((Application.Height / 2) + Application.Top) - (.Height / 2))
.Left = Int(((Application.Width / 2) + Application.Left) - (.Width / 2))
End With
End sub
Code in worksheet or Module:
Sub Open_Userform
UserForm1.Show False
End sub
Have a great day!
I am attempting to select a range of cells. I have done this before but am having trouble with the syntax.
Sub ChgDateX()
Range("A41").Select
Do
If ActiveCell.Value = "Last Updated" Then
mydate = ActiveCell.Offset(-40, 0).Value
'Cells(ActiveCell.Offset(0, 1), ActiveCell.Offset(0, 9)).Select
ActiveCell.Offset(0, 1).Value = mydate
ActiveCell.Offset(0, 2).Value = mydate
ActiveCell.Offset(0, 3).Value = mydate
ActiveCell.Offset(0, 4).Value = mydate
ActiveCell.Offset(0, 5).Value = mydate
ActiveCell.Offset(0, 6).Value = mydate
ActiveCell.Offset(0, 7).Value = mydate
ActiveCell.Offset(0, 8).Value = mydate
ActiveCell.Offset(0, 9).Value = mydate
ActiveCell.EntireRow.Select
Selection.NumberFormat = "m/d/yyyy"
ActiveCell.Offset(1, 0).Select
Else: ActiveCell.Offset(1, 0).Select
End If
Loop Until ActiveCell.Value = "" & ActiveCell.Offset(-3, 0).Value = ""
End Sub
I am trying to get away from the individual offset = mydate type coding.
Couple of things:
This code:
Loop Until ActiveCell.Value = "" & ActiveCell.Offset(-3, 0).Value = ""
Doesn't work as expected because the correct operator you're looking for is And and not &
You don't have to "Select" anything. You can just put a reference to a cell in a variable (see my code).
Also, since you are always moving down to the next cell in the loop, you can put that outside of the IF statement.
Based on your code I think you're looking for something like this:
Option Explicit
Sub test()
Dim r As Range
Dim myDate As Date
Set r = Range("A41")
Do
If (r.Value = "Last Updated") Then
myDate = r.Offset(-40, 0).Value
With Range(r.Offset(0, 1), r.Offset(0, 9))
.Value = myDate
.NumberFormat = "m/d/yyyy"
End With
End If
Set r = r.Offset(1, 0)
Loop Until r.Value = vbNullString And r.Offset(-3, 0).Value = ""
End Sub
Try this:
ActiveCell.Range("B1:J1").Value = MyDate
How about this ... with 1 note. I wouldn't advise the looping like this. Perhaps you can filter on Column A <> "" or something, then just loop through the visible cells? Hard to say without knowing what you are doing.
Option Explicit
Sub ChgDateX()
Range("A41").Select
Do
If ActiveCell.Value = "Last Updated" Then
Range(ActiveCell.Offset(0, 1), ActiveCell.Offset(0, 9)).Value = ActiveCell.Offset(-40, 0).Value
ActiveCell.EntireRow.NumberFormat = "m/d/yyyy"
End If
ActiveCell.Offset(1).Select
Loop Until ActiveCell.Value = "" & ActiveCell.Offset(-3, 0).Value = ""
End Sub