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
Related
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
So, I made a fun and simple macro that randomly selects R, G, and B values until it uses every possible combination (skipping repeats), and setting the color values of a 10x10 square with each new color.
The only problem is that I have run into the limit for the number of cell formats. Microsoft says that the limit should be around 64000, but I found it to be exactly 65429 on a blank workbook in Excel 2013.
I've included a clear format code, but it seems to have no effect:
Cells(X, Y).ClearFormats
Microsoft lists some resolutions, but 3 out of the 4 of them are essentially "Don't make too many formats", and the 4th format is to use a third party application.
Is there really nothing that can be done in VBA?
A1:J10 will print a new color
K1 will print the percentage to completion
L1 will print the number of colors used
M1 will print the number of times a color combination is repeated
Dim CA(255, 255, 255) As Integer
Dim CC As Long
Dim RC As Long
Dim R As Integer
Dim G As Integer
Dim B As Integer
Dim X As Integer
Dim Y As Integer
CC = 0
RC = 0
X = 1
Y = 1
Do While ColorCount < 16777216
R = ((Rnd * 256) - 0.5)
G = ((Rnd * 256) - 0.5)
B = ((Rnd * 256) - 0.5)
If CA(R, G, B) <> 1 Then
CA(R, G, B) = 1
'Step down to the next row
'If at the 10th row, jump back to the first and move to the next column
If X < 10 Then
X = X + 1
Else
X = 1
If Y < 10 Then
Y = Y + 1
Else
Y = 1
End If
End If
Cells(X, Y).ClearFormats 'doesn't do what I hope :(
Cells(X, Y).Interior.Color = RGB(R, G, B)
CC = CC + 1
Cells(1, 11).Value = (CC / 16777216) * 100
Cells(1, 12).Value = CC
Else
RC = RC + 1
Cells(1, 13).Value = RC
End If
Loop
There are several ways to resolve this issue, but the cleanest and easiest method is to remove all extra styles (I have seen workbooks with 9000+ styles )
With the following simple VBA code you can remove all non-builtin styles and in the vast majority of cases this fixes the error.
Sub removeStyles()
Dim li as long
On Error Resume Next
With ActiveWorkbook
For li = .Styles.Count To 1 Step -1
If Not .Styles(li).BuiltIn Then
.Styles(li).Delete
End If
Next
End With
End Sub
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
I have been trying forever to try and figure this out. I have a set of data in a certain sheet in my Excel file. I have written code so that it outputs some of that information to another sheet. I don't know how to get the function to loop through all the different data sets and output them into the "Output" sheet in my excel file on different rows.
This is what I have so far. Can someone please help?
How do I get the function to run through about 6 data sets that include 5 cells in the column until there are 2 blank cells?
How do I output those different results to another sheet? I already have them outputting the first data set and it works fine. I just need to know how to do the other ones.
Thank you!
Sub EstBatch()
'variables
Dim N As String
Dim D As Date
Dim P As Integer
Dim H As Single
Dim NS As Integer
Dim NL As Integer
Dim BP As Currency
Dim OH As Single
Dim OC As Currency
Dim TP As Currency
Dim PPBR As Currency
Dim EHP As Single
Dim batches As Range
'inputs
N = Sheets("Batch Input").Range("A1").Value
D = Sheets("Batch Input").Range("B1").Value
P = Sheets("Batch Input").Range("A2").Value
H = Sheets("Batch Input").Range("A3").Value
PPBR = Sheets("User Form").Range("C22").Value
EHP = Sheets("User Form").Range("C23").Value
Range("A1").Select
'Processes
BP = P * PPBR
OH = H - 5
If P > 120 Or P < 20 Then
MsgBox ("Cannot Accommodate Group")
ElseIf P >= 20 And P <= 25 Then
NS = 1
NL = 0
ElseIf P >= 26 And P <= 50 Then
NS = 2
NL = 0
ElseIf P >= 51 And P <= 60 Then
NS = 0
NL = 1
ElseIf P >= 61 And P <= 85 Then
NS = 1
NL = 1
ElseIf P >= 86 And P <= 120 Then
NS = 0
NL = 2
End If
If OH > 4 Then
OH = 4
OC = BP * OH * EHP
ElseIf 0 < OH <= 4 Then
OC = BP * OH * EHP
ElseIf OH <= 0 Then
OC = 0
End If
TP = BP + OC
'outputs
Sheets("Batch Output").Range("A2").Value = N
Sheets("Batch Output").Range("B2").Value = D
Sheets("Batch Output").Range("C2").Value = P
Sheets("Batch Output").Range("D2").Value = H
Sheets("Batch Output").Range("E2").Value = PPBR
Sheets("Batch Output").Range("F2").Value = EHP
Sheets("Batch Output").Range("G2").Value = NS
Sheets("Batch Output").Range("H2").Value = NL
Sheets("Batch Output").Range("I2").Value = BP
Sheets("Batch Output").Range("J2").Value = OH
Sheets("Batch Output").Range("K2").Value = OC
Sheets("Batch Output").Range("L2").Value = TP
End Sub
Welcome to StackOverflow. Great first question.
I think what you're reaching for is how to use loops in solving a problem like this.
One easy way to do loops is with a counter, as in the examples I've given below. If appropriate, you can also use a range of cells to loop through data, as described in this answer: https://stackoverflow.com/a/19394207/2665195.
Starting with your second question: if you want a separate sheet for each output you can use Sheets.Add and paste into that new sheet. To do this you will want to use a variable naming convention like Sheets("Batch Output" & X).Range. In this way you can Dim X as Integer and loop through the process incrementing the X integer with each loop. Here's some sample code you can adapt for your purpose:
Sub ExampleAddSheets()
Dim intX As Integer
intX = 1
Dim wsBatchOutput As Worksheet
For intX = 1 To 6
Set wsBatchOutput = Worksheets.Add 'adds a worksheet and tags it to a variable
wsBatchOutput.Name = "BatchOutput" & intX 'names the worksheet
wsBatchOutput.Range("A1").Value = "Data here. Example " & intX
Next intX
Set wsBatchOutput = Nothing
End Sub
I don't know what your data source looks like, but hopefully it is set up in a way that you can turn the inputs aquisition into a loop. For example, if the data came into the system in rows (which your example does not seem to do) you could just increment the row number, something like this:
Sub ExampleSetInputs()
'variables
Dim N As String
Dim D As Date
Dim P As Integer
Dim H As Single
Dim PPBR As Currency
Dim EHP As Single
Dim intRow As Integer
intRow = 2
'inputs
For intRow = 2 To 7
N = Sheets("Batch Input").Range("A" & intRow).Value
D = Sheets("Batch Input").Range("B" & intRow).Value
P = Sheets("Batch Input").Range("C" & intRow).Value
H = Sheets("Batch Input").Range("D" & intRow).Value
Next intRow
End Sub
I hope this helps with your challenge.