When I select an item from the drop down list my code goes to palette sheet (Contains of 100 Items cell “B5” has match formula and named as “Ref_rowOffset”. Next to items, I have 4 colours A, B, C, D) find the item and applies the colours for the tables. The table has been referenced as A, B, C, D. But as I have some sheets that contains from many pivot tables and slicers so the code won’t work for it. So the plan is to name ActiveWorkbook.Styles as let’s say as ("A") and use as reference. Any ideas would be fantastic?
Public Function get_color(str_type As String) As String
Dim iColOffset As Integer
Dim strRange As Range
Select Case str_type
Case Is = "A"
iColOffset = 1
Case Is = "B"
iColOffset = 2
Case Is = "C"
iColOffset = 3
Case Is = "D"
iColOffset = 4
Case Else
End Select
iRowOffset = Sheets("Palette").Range("Ref_rowOffset").Value
Set strRange = Sheets("Palette").Range("B5")
get_color = strRange.Offset(iRowOffset, iColOffset).Interior.Color
End Function
Public Sub ABSD()
Sheets("Dashboard").Range("A").Interior.Color = get_color("A")
Sheets("Dashboard").Range("B").Interior.Color = get_color("B")
Sheets("Dashboard").Range("C").Interior.Color = get_color("C")
Sheets("Dashboard").Range("D").Interior.Color = get_color("D")
End Sub
Related
I have a sheet with 2 tables. I want to find and return the cell of column 1 which has the minimum proteges.
For example, my code would return either Phil,Levy or Sean, Montain in the first run. (then my spreadsheet will add +1 to one of the two - this is already set in excel). etc....
Coach List Protégées
Phil, Levy 7
Sean, Monteine 7
Victor, Chatelais 8
I have write a code but unfortunately ot does it randomly. Any thoughts ?
Code:
Dim Coach As String
Dim ws As Worksheet, t As ListObject, r As Long
For Each t In MyWorksheet.ListObjects
Select Case t.Name
Case "Table1", "Table3", "Table4", "Table6", "Table8", "Table10", "Table12", "Table14", "Table16"
'do nothing
Case Else
'Coach = Application.WorksheetFunction.Min(t.ListColumns(2).Range)--> could use that ?
For r = 1 To t.DataBodyRange.Rows.Count
For r = t.DataBodyRange.Rows.Count To 1 Step -1
If t.DataBodyRange(r, 2) <= t.DataBodyRange(r + 1, 2) Then
Coach = t.DataBodyRange(r , 1)
End If
Next r
End Select
Next t
I think your method needs a variable for the lowest number found as each row is compared.
p = 9999
For r = 1 To t.DataBodyRange.Rows.Count
If t.DataBodyRange(r, 2) <= p Then
p = t.DataBodyRange(r, 2)
Coach = t.DataBodyRange(r, 1)
End If
Next r
I have the following code that transfers a student over to another sheet if the student is delayed. The student is delayed if enroll-period is 132 or less for a master's student and 130 and less for a bachelor student. This code copys all of the headers and takes all of the columns and data over to the new sheet if the student is delayed. I only need the data from columns A, B, D, G, H, I, M and put it over in the new sheet in columns A, B, C, D, E, F, G, if the student is delayed. How should i change this code so it will do that?
Thanks in advance!
Sub findDelayedStudents()
Dim wsIn As Worksheet
Dim wsOut As Worksheet
Set wsIn = ThisWorkbook.Worksheets("Base")
Set wsOut = ThisWorkbook.Worksheets("Delayed Students")
wsOut.Cells.ClearContents
wsIn.Rows(1).Copy Destination:=wsOut.Range("A1")
Dim lLastInputRow As Long
Dim lCurrentInputRow As Long
Dim lCurrentOutputRow As Long
lLastInputRow = wsIn.Cells(wsIn.Rows.Count, 1).End(xlUp).Row
lCurrentOutputRow = 2
For lCurrentInputRow = lLastInputRow To 2 Step -1
If (wsIn.Cells(lCurrentInputRow, 10) = "B" And wsIn.Cells(lCurrentInputRow,
5).Value <= 130) Or _
(wsIn.Cells(lCurrentInputRow, 10) = "M" And wsIn.Cells(lCurrentInputRow,
5).Value <= 132) Then
wsIn.Rows(lCurrentInputRow).Copy
Destination:=wsOut.Cells(lCurrentOutputRow, 1)
lCurrentOutputRow = lCurrentOutputRow + 1
End If
Next lCurrentInputRow
wsIn.Range("A1").Select
Set wsIn = Nothing
Set wsOut = Nothing
End Sub
Currently you copy over entire rows using the inbuild copy paste methods in this part of your code:
wsIn.Rows(lCurrentInputRow).Copy
Destination:=wsOut.Cells(lCurrentOutputRow, 1)
lCurrentOutputRow = lCurrentOutputRow + 1
It would be easiest to replace that with cell wise replication of your values like such:
wsOut.Cells(lCurrentOutputRow,1) = wsIn.Cells(lCurrentInputRow,1) 'A to A
wsOut.Cells(lCurrentOutputRow,2) = wsIn.Cells(lCurrentInputRow,2) 'B to B
wsOut.Cells(lCurrentOutputRow,3) = wsIn.Cells(lCurrentInputRow,4) 'D to C
wsOut.Cells(lCurrentOutputRow,4) = wsIn.Cells(lCurrentInputRow,7) 'G to D
wsOut.Cells(lCurrentOutputRow,5) = wsIn.Cells(lCurrentInputRow,8) 'H to E
wsOut.Cells(lCurrentOutputRow,6) = wsIn.Cells(lCurrentInputRow,9) 'I to F
wsOut.Cells(lCurrentOutputRow,7) = wsIn.Cells(lCurrentInputRow,13) 'M to G
lCurrentOutputRow = lCurrentOutputRow + 1
To set the correct headers replace this part of your code:
wsIn.Rows(1).Copy Destination:=wsOut.Range("A1")
With:
wsOut.Cells(1,1) = wsIn.Cells(1,1) 'A to A
wsOut.Cells(1,2) = wsIn.Cells(1,2) 'B to B
wsOut.Cells(1,3) = wsIn.Cells(1,4) 'D to C
wsOut.Cells(1,4) = wsIn.Cells(1,7) 'G to D
wsOut.Cells(1,5) = wsIn.Cells(1,8) 'H to E
wsOut.Cells(1,6) = wsIn.Cells(1,9) 'I to F
wsOut.Cells(1,7) = wsIn.Cells(1,13) 'M to G
Two days of continual failure. I am using a barcode system which has a barcode scanner which scans a barcode of alpha-numeric text and places it into an ActiveX textbox. It enters the text one letter at a time, and upon the completion of the entire barcode, it matches up to a Case selection, which then deletes the text in the box to get ready for the next scan.
The issue I happen to be facing is inside of the textbox. For whatever reason, the text goes into the textbox and occasionally ~ (1 time in one hour or 0 times in 8 hours) it will not complete the case. The exact text inside of the textbox which matches one of the cases is not counted and stays inside the box. At this point, any future scans are appended to the end of the text inside of the box.
Below is a sample of the variables, a case, and one of the events occuring based on case selection.
Variables
Private Sub TextBox1_Change()
Dim ws As Worksheet, v, n, t, b, c, e, f, h, j, k, i1, i2, i3, i4
Set ws = Worksheets("Sheet1")
v = TextBox1.Value
n = 0
t = 0
b = 0
c = 0
e = 0
f = 0
h = 0
j = 0
k = 0
i1 = 0
i2 = 0
i3 = 0
i4 = 0
Case
Select Case v
Case "2 in x 16 ft R -1": n = 9
t = 1
b = 10
c = 1
e = 11
f = 6
g = "2 in x 16 ft"
h = 40
j = 0.296
k = 1
Stuff that is done based on case type
'n = Sets the column reference for waste - not used?
't = Sets the cutting station column to be used (1,2,3) for the sq yards, row, and column of last scanned item for each station
'b = Sets the row reference for adding cut rolls waste + regular row reference for cut rolls
'c = Sets the column reference for adding cut rolls waste + regular column refernce for cut rolls
'e = Sets the column reference for taking 1 master roll out
'f = Sets the row reference for taking 1 master roll out
'g = name of the item being used for the time stamp
'h = Number of rolls coming out of the master roll
'j = The amount of Sq yards in the cut roll (to be used for waste)
'k = Case Selection
'i1 = Count for Cutting Station 1 timestamp, row reference
'i2 = Count for Cutting Station 2 timestamp, row reference
'i3 = Count for Cutting Station 3 timestamp, row reference
'i4 = Count for Cutting Station 1 timestamp, row reference - not used in this worksheet
If k = 1 And t = 1 Then
'Cutter 1 items
ws.Cells(1, t) = b
ws.Cells(2, t) = c
ws.Cells(3, t) = j
ws.Cells(4, t) = b
ws.Cells(5, t) = c
ws.Cells(6, t) = f
ws.Cells(7, t) = h
ws.Cells(b, c) = ws.Cells(b, c) + h
' adding different number based on case
ws.Cells(f, e) = ws.Cells(f, e) - 1
' always subtracts 1 from certain range based on case
i1 = ws.Cells(1, 30)
Cells(i1, 19).Value = Format(Now, "mm/dd/yyyy AM/PM h:mm:ss")
Cells(i1, 20).Value = g
TextBox1.Activate
TextBox1.Value = ""
Remember the text enters in one character at a time until the entire barcodes information is passed into the ActiveX textbox.
I can set a max length, but upon the max length it stays in the textbox. If I set the textbox to "", the next character in the barcode starts again and the append issue continues.
Is there a way to not have the case selection start upon the entry of each single character? Is there a way to have the textbox delete the extra information. If you set it to delete something which does not match a case, then it will delete anything entered since it puts one character in at a time.
Best regards,
Ford
My purpose is to split a task into constituent tasks and find the most important one.The macro is written in "May" sheet of workallotment.xlsm and the tasks are in tasks.xlsx
For example:
Constituents Constituents Important Imp
Praveen T1 T2 T3 T4 T5 T6 T1+T2+T3 =T5 T3+T5+T6 =T9 T1 T6
4 3 1 2 8 9
Karthik P1 P2 P3 P4 " among T1,T2,T3- T1 takes more time".its imp
6 3 2 2
Walter c1 c2 c3 c4
1 2 3 4
Arvind g1 g2 g3
2 1 3
Sreelatha h1 h2 h3
2 1 1
Code:
Sub workallotment()
Dim workallotmentWB, tasksWB As Workbook
Dim waSheet As Worksheet
Dim str(9) As String
Dim splitArray() As String, S(10) As String
Dim col_new As Integer
Dim wa_nameRng As Range
Dim r As Integer, max As Integer, imps As String
Dim wa_nameRow, wa_firstRow, wa_lastRow As Integer 'work allotment rows
Dim t_firstRow, t_lastrow As Integer 'task rows
Dim curTaskCol As Integer 'current task column
Dim wa_tmpcol As Integer 'work allotment, temp column
Set workallotmentWB = ThisWorkbook
Set tasksWB = Workbooks.Open("E:/tasks.xlsx")
'notes on data structure:
'- tasks workbook:
'first name starts in A1 of "Sheet1"
'- workallotment workbook:
'first name starts in A2 of Sheet named "workallotment"
'tasks are to be written starting in B2
'in Row 1 are headers (number of days)
t_firstRow = 1
wa_firstRow = 2
wa_nameRow = 0
Set waSheet = workallotmentWB.Worksheets("May") ' in this file - workallotment.xlsm
With tasksWB.Worksheets("May") ' in tasks.xlsx which is attached
'finding the last rows
t_lastrow = .Range("A1000000").End(xlUp).row + 1
wa_lastRow = waSheet.Range("A1000000").End(xlUp).row
'goes through all the names in tasks_Sheet1
For r = t_firstRow To t_lastrow Step 2
Set wa_nameRng = waSheet.Range("A:A").find(.Range("A" & r).Value, _
LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext, MatchCase:=False)
If Not wa_nameRng Is Nothing Then
wa_nameRow = wa_nameRng.row
curTaskCol = 2
wa_tmpcol = 2
Do While Not IsEmpty(.Cells(r, curTaskCol).Value)
For C = 1 To .Cells(r + 1, curTaskCol).Value
waSheet.Cells(wa_nameRow, wa_tmpcol).Value = .Cells(r, curTaskCol).Value
wa_tmpcol = wa_tmpcol + 1
Next C
curTaskCol = curTaskCol + 1
Loop
End If
Next r
End With
MsgBox ("done")
For r = t_firstRow To t_lastrow Step 2 ' loop to find importance
col = 2 'setting to initial col
curTaskCol = 17 ' position input - constituent jobs at 17th col in tasks.xls
Do While Not IsEmpty(tasksWB.Worksheets("May").Cells(r, curTaskCol).Value)
str(curTaskCol - 16) = tasksWB.Worksheets("May").Cells(r, curTaskCol).Value
' reading input to first array of string element
substr = Left(str(curTaskCol - 16), Application.WorksheetFunction.find("=", str(curTaskCol - 16)) - 1) ' if T1+T2=T3 it'll look before "=" symbol
MsgBox (substr)
splitArray() = Split(substr, "+") ' if T1+T2 it will be split as T1 & T2
For i = LBound(splitArray) To UBound(splitArray)
S(i + 1) = splitArray(i) ' assigning split elements to string array
Next i
For i = LBound(splitArray) To UBound(splitArray)
col_new = 2 ' checking from 2nd column
Do While Not IsEmpty(tasksWB.Worksheets("May").Cells(r, col_new).Value)
If (S(i + 1) = tasksWB.Worksheets("May").Cells(r, col_new).Value) Then 'initialising max and imps
imps = S(i + 1) ' most important job
max = tasksWB.Worksheets("May").Cells(r + 1, col_new).Value
End If ' maximum time taken for task
col_new = col_new + 1
Loop
For j = LBound(splitArray) To UBound(splitArray)
col_new = findcol(S(j + 1), r, tasksWB)
If (max < tasksWB.Worksheets("May").Cells(r + 1, col_new).Value) Then
max = tasksWB.Worksheets("May").Cells(r + 1, col_new).Value
imps = tasksWB.Worksheets("May").Cells(r, col_new).Value
End If
Next j
Next i
tasksWB.Worksheets("May").Cells(r, curTaskCol + 6).Value = imps
' assign most IMPORTANT task on 6th column from current column
curTaskCol = curTaskCol + 1 ' RUNTIME ERROR 1004
Loop
Next r
End Sub
Public Function findcol(S As String, row As Integer, theWB As Workbook) As Integer
Dim col As Integer, addr As Integer
col = 2 ' checking from column 2
'Set tasksWB = Workbooks.Open("E:/tasks.xlsx")
Do While Not IsEmpty(theWB.Worksheets("May").Cells(row, col).Value)
If (StrComp(Trim(S), Trim(theWB.Worksheets("May").Cells(row, col).Value)) = 0) Then
addr = col ' if task string is found in column
End If
col = col + 1 ' return column found
Loop
findcol = addr
End Function
Krishnan,
In your main proc workallotment you declare the variable tasksWB.
In your method 'findcol' you then reference tasksWB. It looks like you've pulled this code out of the main proc. The tasksWB only has scope within workallot and so you need to give findcol this object so it will have it within it's scope as well.
I would recommend that you pass the tasksWB into the method, as a third parameter.
Your method would then look as follows.
Edit for your comment of why findcol doesn't return. The Exit Function will ensure that the method is exited immediately after setting the return value. Without this you would end up in the asking for the correct task name again.
Public Function findcol(S As String, row As Integer, theWB as Workbook) As Integer
col = 2 ' checking from column 2
Do While Not IsEmpty(theWB.Worksheets("May").Cells(row, col).Value)
If (S = theWB.Worksheets("May").Cells(row, col).Value) Then
findcol = col ' if task string is found in column
Exit Function
End If
'MsgBox ("Enter correct task names") Not sure why this is here.
col = col + 1 ' return column found
Loop
End Function
and you'd call it with
col_new = findcol(S(j + 1), r, tasksWB) ' ERROR line function to find column of task string
This will ensure that you do not "leak" your variable definition into global scope, and that you also ensure that your method doesn't depend on external globals.
Edit 3:
Your findcol is still wrong.
Public Function findcol(S As String, row As Integer, theWB As Workbook) As Integer
Dim col As Integer
'******* you don't need this because you can exit early
'Dim addr As Integer
col = 2 ' checking from column 2
'***** THIS LINE NEEDS TO BE REMOVED because you are using theWB being passed in *****
'Set tasksWB = Workbooks.Open("E:/tasks.xlsx")
Do While Not IsEmpty(theWB.Worksheets("May").Cells(row, col).Value)
'****** this line must use theWB
'If (StrComp(Trim(S), Trim(tasksWB.Worksheets("May").Cells(row, col).Value)) = 0) Then
If (StrComp(Trim(S), Trim(theWB.Worksheets("May").Cells(row, col).Value)) = 0) Then
'************* you can exit early once you've found what you need.
'addr = col ' if task string is found in column
findcol = col
exit function
End If
col = col + 1 ' return column found
Loop
' You can exit early so don't need this.
' findcol = addr
End Function
You should probably do a check when you call the function that the value hasn't returned 0, eg
new_col = findcol( .... )
if new_col = 0 then
msgbox "couldn't find the column with that str" & S(j + 1)
end if
tasksWB isn't recognized in the findcol function as it is declared as Private (=Dim) in the main process.
Declare it at the top of your module, and it'll work! ;)
I have 4 strings in variables a,b,c and d. I need to randomly order these variables in such a way so that I can input them into 4 different text boxes but not the same ones every time the program is ran.
I've tried to simplify it for myself by putting the strings into an array. Tell me what I'm doing wrong or if there's a way I could do it much easier.
Private Sub Random()
For i = 1 To 4
If a = 0 Then
a = r.Next(2, 5)
ElseIf b = 0 Then
Do Until b <> a
b = r.Next(2, 5)
Loop
ElseIf c = 0 Then
Do Until c <> a Or c <> b
c = r.Next(2, 5)
Loop
ElseIf d = 0 Then
Do Until d <> a Or d <> b Or d <> c
d = r.Next(2, 5)
Loop
End If
Next
End Sub
Here is one way to do it:
Dim a As String = "a"
Dim b As String = "b"
Dim c As String = "c"
Dim d As String = "d"
Dim all As String() = {a, b, c, d}
Dim random As New Random
Dim allRandom As String() = all.OrderBy(Function() random.Next).ToArray