Sub FallOrSpringsemester()
Dim enrollPeriod As String
Dim i As Integer
Dim LastRow As Integer
Dim w As Worksheet
Dim text As String
Set w = Sheets.Add(after:=Sheets(Sheets.Count))
w.Name = "oldest Students"
Worksheets("oldest Students").Cells(1, 1) = "Student_ID"
Worksheets("oldest Students").Cells(1, 2) = "Enroll_Date"
Worksheets("oldest Students").Cells(1, 3) = "Program_Type_Name"
Worksheets("oldest Students").Cells(1, 4) = "Enrollment_Period"
LastRow = Worksheets("Base").Range("D" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
Worksheets("oldest students").Cells(i, 1) = Worksheets("Base").Cells(i, 12)
Worksheets("oldest students").Cells(i, 2) = Worksheets("Base").Cells(i, 4)
Worksheets("oldest students").Cells(i, 3) = Worksheets("Base").Cells(i, 11)
Above this coding I ofc have my dimed variables and also coding for creating a new sheet.
I have trouble with this part as it will no do the calculations and tells me there is an error
"13": type miss match
If enrollPeriod Mod 2 = 0 Then
Worksheets("oldest Students").Cells(i, 2) = "Spring"
enrollPeriod = enrollPeriod + 1
Worksheets("oldest Students").Cells(i, 1) = 2018 - ((138 - enrollPeriod) / 2)
Else
Worksheets("oldest Students").Cells(i, 2) = "Fall"
Worksheets("oldest Students").Cells(i, 1) = 2018 - ((138-enrollPeriod) / 2)
End if
Next
End Sub
I think enrollPperiod should be an integer... that should fix it
Related
I received help in solving a previous question. I would like to solve this problem similarly.
So the situation is similar to a Countifs function, in that I would like it to count if a range equals a certain building, as well as if the date and time that is offset equals a certain date. For example, if the cell in "C1" = "Irving Building" And if the value in "K1" = "Monday" Then I would like it to display in "S1". More specifically if "C1" = "Irving Building" then I want it to count into whatever day and time that corresponds with it, in Column K.
Private Sub TimeAndDate()
Dim n As Double
Dim rep As Worksheet
Dim ws As Worksheet
Dim LastRow As Double
Set rep = Worksheets("Report")
rep.Columns("K:L").ClearContents
For n = 1 To ThisWorkbook.Sheets.Count
Set ws = Worksheets(n)
If IsNumeric(ws.Name) Then
LastRow = rep.Range("K1", rep.Range("K1").End(xlDown)).Rows.Count
LastRow = LastRow + 1
If rep.Range("K1") = "" Then
ws.Range("C2", ws.Range("C2").End(xlDown)).Copy _
Destination:=rep.Range("K1")
ws.Range("C2", ws.Range("C2").End(xlDown)).Copy _
Destination:=rep.Range("L1")
Else:
ws.Range("C2", ws.Range("C2").End(xlDown)).Copy _
Destination:=rep.Range("K" & LastRow)
ws.Range("C2", ws.Range("C2").End(xlDown)).Copy _
Destination:=rep.Range("L" & LastRow)
End If
End If
Next n
Dim rDts As Range
Dim vDts As Variant
Dim vCnts As Variant
Dim vAP As Variant 'for the AM PM count
Dim vDbld As Variant 'for the date by building
Dim vTbld As Variant 'for thee time by building
Dim i As Long, J As Long
'read dates into array -- faster processing
With rep
vDts = .Range(.Cells(1, 11), .Cells(.Rows.Count, 11).End(xlUp))
End With
'Results array
ReDim vCnts(1 To 7, 1 To 2)
vCnts(1, 1) = "Sunday"
vCnts(2, 1) = "Monday"
vCnts(3, 1) = "Tuesday"
vCnts(4, 1) = "Wednesday"
vCnts(5, 1) = "Thursday"
vCnts(6, 1) = "Friday"
vCnts(7, 1) = "Saturday"
ReDim vAP(1 To 2, 1 To 2)
vAP(1, 1) = "AM"
vAP(2, 1) = "PM"
ReDim vDbld(1 To 13, 1 To 2)
vDbld(1, 1) = "Irving Building"
vDbld(2, 1) = "Memorial Building"
vDbld(3, 1) = "West Tower"
vDbld(4, 1) = "Witting Surgical Center"
vDbld(5, 1) = "Madison Irving Surgical Center"
vDbld(6, 1) = "Marley Education Center"
vDbld(7, 1) = "410 South Crouse"
vDbld(8, 1) = "Physicians Office Building"
vDbld(9, 1) = "Crouse Business Center"
vDbld(10, 1) = "Commonwealth Place"
vDbld(11, 1) = "Irving - Memorial Connector"
vDbld(12, 1) = "Crouse Garage"
vDbld(13, 1) = "CNY Medical Center"
'Do the counts
For i = 1 To UBound(vDts, 1)
J = Weekday(vDts(i, 1))
vCnts(J, 2) = vCnts(J, 2) + 1
If Hour(vDts(i, 1)) < 12 Then
vAP(1, 2) = vAP(1, 2) + 1
Else
vAP(2, 2) = vAP(2, 2) + 1
End If
Next i
'output the results
rep.Range("E1:E14").Copy rep.Range("Q1")
rep.Range("N2:N8").Copy
rep.Range("R1").PasteSpecial xlPasteAll, xlPasteSpecialOperationNone, _
False, True
rep.Range("N11:N12").Copy
rep.Range("Y1").PasteSpecial xlPasteAll, xlPasteSpecialOperationNone, _
False, True
rep.Range("N1") = "DATE"
rep.Range("O1") = "COUNT"
rep.Range("N10") = "TIME"
rep.Range("O10") = "COUNT"
rep.Range("N2:O8").Value = vCnts
rep.Range("N11:O12").Value = vAP
The part that I am needing help on is this part here. These are the variants that I'd like to use, but like I said, earlier, I am unsue as to how to do this without running a ton of countifs statements.
Dim vDbld As Variant 'for the date by building
ReDim vDbld(1 To 13, 1 To 2)
vDbld(1, 1) = "Irving Building"
vDbld(2, 1) = "Memorial Building"
vDbld(3, 1) = "West Tower"
vDbld(4, 1) = "Witting Surgical Center"
vDbld(5, 1) = "Madison Irving Surgical Center"
vDbld(6, 1) = "Marley Education Center"
vDbld(7, 1) = "410 South Crouse"
vDbld(8, 1) = "Physicians Office Building"
vDbld(9, 1) = "Crouse Business Center"
vDbld(10, 1) = "Commonwealth Place"
vDbld(11, 1) = "Irving - Memorial Connector"
vDbld(12, 1) = "Crouse Garage"
vDbld(13, 1) = "CNY Medical Center"
I apologize if this is confusing, I am not completely sure how to word it, thanks in advance.
This is an example of what I'd like it to look like:
What you simply can is to check with Application.Match if the string is in the array and it will give back the index, because this function can only handle one dimensional arrays, there is another function that will give back one dimension of the array. After that you can check the offset and do something with it like this:
Dim mindex as Variant
mindex = Application.Match(rDts(i, 3), Only1D(vDbld, 1), 0)
If Not IsError(mindex) Then
'do stuff i.e
vDbld(mindex, 2) = vDbld(mindex, 2) + 1
End If
Function Only1D(arr As Variant, d As Long)
Dim size As Long: size = UBound(arr, d)
Dim arr2 As Variant
ReDim arr2(1 To size)
For i = 1 To size
arr2(i) = arr(i, d)
Next
Only1D = arr2
End Function
I have the following code. The Loop seems to function well but the ColNum and RowNum lines are only creating 0's the data up to this point is filled out so a blank isn't causing the issue
If Sheets("Control").Range("B6") = "#.#" Then
For i = 1 To ColACount - 2
If FullData(i, 3) <= Sheets("Control").Range("B5") _
And FullData(i, 3) >= Sheets("Control").Range("B4") Then
ColNum = WorksheetFunction.Match(FullData(i, 1), Application.Index(RetGross, 1), 0)
RowNum = WorksheetFunction.Match(FullData(i, 3), Application.Index(RetGross, , 1), 0)
If RetGross(RowNum, ColNum) = "" Then 'Prevents overwriting
RetGross(RowNum, ColNum) = FullData(i, 4)
End If
End If
Next i
End If
I have used Application.Worksheetfunction on the Index and then it really crashes.
Edit: All Code
Sub TransferData()
'Declarations
Dim ReturnWB As String 'File name from Investment metrics
Dim ReturnWBtab1 As String
Dim ReturnWBtab2 As String
Dim ReturnWBtab3 As String
Dim ColACount As Integer 'Total data in column A of Return Puller
Dim FullDataP As Variant ' Pulling data
Dim FullData As Variant ' Building Matrix
Dim Names As Variant
Dim Unique As Integer 'Total Number of unique names
Dim Months As Integer 'Months Specified
Dim StartYear As Integer
Dim EndYear As Integer
Dim StartMonth As Integer
Dim EndMonth As Integer
Dim RetGross As Variant 'Tab data
Dim RetNet As Variant 'Tab data
Dim MValues As Variant 'Tab data
Dim Corner As String 'set the corner value for pasting the array
Dim ColNum As Integer 'Dynamic variable to update matrix
Dim RowNum As Integer 'Dynamic variable to update matrix
Dim First As Integer 'First row for shading - Dynamic and changing
Dim Inceptions As Variant 'Inception Dates
Dim BotRow As Integer 'Testing for Gaps
Dim TopRow As Integer 'Testing for Gaps
'Call Clearing
Workbooks("Return Formatter - Investment Metrics.xlsm").Activate
'Setting Names
ReturnWB = Sheets("Control").Range("B3") & ".xls" 'Excel Name
ReturnWBtab1 = "Pre Fee Returns" 'Tab Name
ReturnWBtab2 = "After Fee Returns" 'Tab Name
ReturnWBtab3 = "Total Fund Market Value" 'Tab Name
'Error Control
On Error GoTo Err1
'Prepping the Dates and Name
StartYear = Year(Sheets("Control").Range("B4"))
EndYear = Year(Sheets("Control").Range("B5"))
StartMonth = Month(Sheets("Control").Range("B4"))
EndMonth = Month(Sheets("Control").Range("B5"))
Months = (EndYear - StartYear + 1) * 12 - (StartMonth - 1) - (12 - EndMonth)
'Find all the unique names/managers and list them
ColACount = WorksheetFunction.CountA(Workbooks(ReturnWB).Sheets(ReturnWBtab1).Range("B:B"))
'Building a Matrix
FullDataP = Workbooks(ReturnWB).Sheets(ReturnWBtab1).Range("B2:E" & ColACount)
FullData = FullDataP
ReDim Preserve FullData(1 To (ColACount - 1), 1 To 5)
'Adding Start Date
FullData(1, 5) = FullData(1, 3)
For i = 2 To (ColACount - 1)
If FullData(i, 1) = FullData(i - 1, 1) Then
FullData(i, 5) = FullData(i - 1, 5)
Else
FullData(i, 5) = FullData(i, 3)
End If
Next i
ReDim Names(1 To 3, 1 To ColACount - 1) 'Setting max size
Names(1, 1) = FullData(1, 1) ' loading first value
Names(2, 1) = FullData(1, 5) ' loading first value
Names(3, 1) = 1 'Tracking the count
x = 1
For i = 1 To (ColACount - 2)
If Names(1, x) <> FullData(i + 1, 1) Then
Names(1, x + 1) = FullData(i + 1, 1)
Names(2, x + 1) = FullData(i + 1, 5)
Names(3, x + 1) = 1 'Tracking the count
x = x + 1
End If
Next i
Unique = WorksheetFunction.Sum(Application.Index(Names, 3)) 'Number of MGRs/Names
ReDim RetGross(1 To Months + 1, 1 To (Unique + 1)) 'Setting Size
ReDim Inceptions(1 To 1, 1 To (Unique + 1)) 'Setting Size
Inceptions(1, 1) = "Inception Date ->"
'Building Dates
For i = 1 To Unique
Inceptions(1, i + 1) = Names(2, i)
Next i
Corner = Sheets("ReturnsGross").Range("A2").Offset(0, Unique).Address
'Dropping Dates
Sheets("ReturnsGross").Range("A2:" & Corner) = Inceptions
'Sheets("ReturnsNet").Range("A2:" & Corner) = Inceptions
'Sheets("MarketValues").Range("A2:" & Corner) = Inceptions
RetGross(1, 1) = "Manager Name ->"
RetGross(2, 1) = WorksheetFunction.EoMonth(DateSerial(Year(Sheets("Control").Range("B4")), Month(Sheets("Control").Range("B4")), 1), 0)
'Building Dates
For i = 1 To Months - 1
RetGross(i + 2, 1) = WorksheetFunction.EoMonth(RetGross(i + 1, 1), 1)
Next i
'Building Names
For i = 1 To Unique
RetGross(1, i + 1) = Names(1, i)
Next i
'RetNet = RetGross 'These Lines will have to change
'MValues = RetGross 'These Lines will have to change
'Code to here function correctly
'Grabbing Data Gross
'Grabbing Data
If Sheets("Control").Range("B6") = "#.#" Then
For i = 1 To ColACount - 2
If FullData(i, 3) <= Sheets("Control").Range("B5") And _
FullData(i, 3) >= Sheets("Control").Range("B4") Then
ColNum = WorksheetFunction.Match(FullData(i, 1), Application.Index(RetGross, 1), 0)
RowNum = WorksheetFunction.Match(FullData(i, 3), Application.Index(RetGross, , 1), 0)
If RetGross(RowNum, ColNum) = "" Then 'Prevents overwriting
RetGross(RowNum, ColNum) = FullData(i, 4)
End If
End If
Next i
End If
Could anyone help me with this please?
It's probably something simple, but I dont't see it.
Thanks in advance.
Object variable or With block variable not set (Error 91)
( in index/match line )
Dim last_row_Datasheet As Long
Dim i As Long
Dim j As Long
Dim found_value As Range
Dim found_value1 As Variant
Dim artnr As Variant
Dim Range_Lookup As Variant
Dim Range_Lookup1 As Variant
For i = 2 To last_row_Datasheet
artnr = Workbooks("queries.xlsm").Worksheets("Data").Cells(i, 2)
Set Range_Lookup = Workbooks("queries.xlsm").Worksheets("artnr_package").Range("A2:A88")
Set Range_Lookup1 = Workbooks("queries.xlsm").Worksheets("artnr_package").Range("A2:A88")
found_value = Application.WorksheetFunction.Index(Range_Lookup, Application.WorksheetFunction.Match(artnr, Range_Lookup1, 0)).Address
found_value1 = Workbooks("queries.xlsm").Worksheets("artnr_package").Range(found_value).Offset(0, 6)
If ActiveSheet.Cells(i, 10) = "Not packed" Then
Workbooks("queries.xlsm").Worksheets("Data").Cells(i, 10) = found_value1
End If
Next i
try this
set found_value = Range_Lookup1.Find(artnr)
found_value1 = Workbooks("queries.xlsm").Worksheets("artnr_package").found_value.Offset(0, 6)
I tried several options and decided to do it with arrays.
I' ve filled the 2 arrays and merged the 2 arrays and search within.
And I think it's must faster, see piece of code below.
Suggestions are always welcome.
Dim art_data() As Variant
ReDim art_data(1 To lr - 1, 1 To 25)
art_data = Workbooks("queries.xlsm").Worksheets("Data").Range("A2:Y" & lr).Value
Dim art_package() As Variant
ReDim art_package(1 To lr1 - 1, 1 To 10)
art_package = Workbooks("queries.xlsm").Worksheets("artnr_package").Range("A2:J88").Value
For i = 1 To lr - 1
For j = 1 To lr1 - 1
If art_data(i, 2) = art_package(j, 1) Then
ReDim Preserve art_data(LBound(art_data) To UBound(art_data), 1 To 35)
art_data(i, 26) = art_package(j, 1)
art_data(i, 27) = art_package(j, 2)
art_data(i, 28) = art_package(j, 3)
art_data(i, 29) = art_package(j, 4)
art_data(i, 30) = art_package(j, 5)
art_data(i, 31) = art_package(j, 6)
art_data(i, 32) = art_package(j, 7)
art_data(i, 33) = art_package(j, 8)
art_data(i, 34) = art_package(j, 9)
art_data(i, 35) = art_package(j, 10)
End If
Next j
Next i
For k = 1 To lr - 1
If Trim(art_data(k, 10)) = "" Then
ReDim Preserve art_data(LBound(art_data) To UBound(art_data), 1 To 35)
art_data(k, 10) = art_data(k, 35)
End If
Next k
How to apply this from A4 instead of A2. Everything else I am happy with. I just want to understand any changes that I need to make to this.
Is it needing changes at "set population"? The 2?
Sub formatresults()
Dim lastRow As Long
Dim pop As Range
Dim rpSet As Range
Dim rpSetNames As Range
Dim sBeg As Integer
Dim sEnd As Integer
Dim rpName As String
Dim x As Integer
Dim y As Integer
lastRow = Range(Cells(99999, 1), Cells(99999, 1)).End(xlUp).row
Set pop = Range(Cells(2, 1), Cells(lastRow, 7))
sBeg = 2
sEnd = 2
y = 1
rpName = Cells(2, 1)
Range(Cells(1, 7), Cells(lastRow, 7)).NumberFormat = "0.00%"
For x = 2 To lastRow
If Cells(sEnd + 1, 1) = rpName Then
sEnd = sEnd + 1
Else
Set rpSet = Range(Cells(sBeg, 1), Cells(sEnd, 7))
Set rpSetNames = Range(Cells(sBeg, 1), Cells(sEnd, 1))
rpSet.BorderAround Weight:=xlMedium
If y Mod 2 = 1 Then rpSetNames.Interior.ColorIndex = 15
sBeg = sEnd + 1
sEnd = sEnd + 1
rpName = Cells(sBeg, 1)
y = y + 1
End If
Next x
End Sub
Many thanks!
I added a new variable StartFrom so that you'll only have to change the value once to make it work on a different range.
Also, I changed the definition of lastRow, take a look at Error in finding last used cell in VBA
Give this a try :
Sub formatresults()
Dim lastRow As Long
Dim pop As Range
Dim rpSet As Range
Dim rpSetNames As Range
Dim sBeg As Integer
Dim sEnd As Integer
Dim rpName As String
Dim x As Integer
Dim y As Integer, _
StartFrom As Integer
StartFrom = 4
lastRow = Range("A" & Rows.Count).End(xlUp).Row
Set pop = Range(Cells(StartFrom, 1), Cells(lastRow, 7))
sBeg = StartFrom
sEnd = StartFrom
y = 1
rpName = Cells(StartFrom, 1) '----
Range(Cells(1, 7), Cells(lastRow, 7)).NumberFormat = "0.00%"
For x = StartFrom To lastRow '----
If Cells(sEnd + 1, 1) = rpName Then
sEnd = sEnd + 1
Else
Set rpSet = Range(Cells(sBeg, 1), Cells(sEnd, 7))
Set rpSetNames = Range(Cells(sBeg, 1), Cells(sEnd, 1))
rpSet.BorderAround Weight:=xlMedium
If y Mod 2 = 1 Then rpSetNames.Interior.ColorIndex = 15
sBeg = sEnd + 1
sEnd = sEnd + 1
rpName = Cells(sBeg, 1)
y = y + 1
End If
Next x
End Sub
I'm trying to record a macro in which if the text in a column header is the same as the text in a row the intersection cell of the row and the column gets highlighted.
For example:
A11: "description"
Y1: "description"
->Y11 should be highlighted
Your answer doesn't seem to intuitively answer the question at hand: How to highlight an intersecting row and column on found match?
A naive approach would be to iterate through the columns and rows to find matches:
Private Sub ColorIntersection()
Application.EnableEvents = False
Application.ScreenUpdating = False
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim cols As Range, rws As Range
Dim lastRow As Integer: lastRow = ws.UsedRange.Rows.Count
Dim lastColumn As Integer: lastColumn = ws.UsedRange.Columns.Count
For Each cols In ws.Range(ws.Cells(1, 1), ws.Cells(1, lastColumn))
If (Not (cols.Value = vbNullString)) Then
For Each rws In ws.Range("A1:A" & lastRow)
If (rws.Value = cols.Value) Then ws.Cells(rws.Row, cols.Column).Interior.Color = 5296210
Next
End If
Next
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
So this is what it is. Works perfectly with what I need (it also highlights a number of cells ahead of the one on the intersection)
Sub BorderForNonEmpty2()
Dim wb As Workbook
Dim wsCurrent As Worksheet
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set wb = ActiveWorkbook
Set wsCurrent = wb.ActiveSheet
Dim atLastCompareDate As Boolean
Dim atLastMPDate As Boolean
Dim mPDateCounter As Integer
Dim compareDateCounter As Integer
mPDateCounter = 3
'loop over each row where the value in column c is not empty, starting at row 3
Do While Not atLastMPDate
Dim mPDate As String
mPDate = wsCurrent.Range("C" + CStr(mPDateCounter)).Value
atLastCompareDate = False
If (mPDate = Null Or mPDate = "") Then
atLastMPDate = True
Else
'loop over each column where the value in row 1 is not empty, starting at column e
compareDateCounter = 5
Do While (Not atLastCompareDate)
Dim compareDate As String
Dim currentCellColumn As String
If (compareDateCounter <= 26) Then
currentCellColumn = Chr((compareDateCounter) + 96)
Else
If (compareDateCounter > 26) And (compareDateCounter Mod 26 = 0) Then
currentCellColumn = Chr(Int(compareDateCounter / 26) - 1 + 96) + Chr(122)
Else
currentCellColumn = Chr(Int(compareDateCounter / 26) + 96) + Chr((compareDateCounter Mod 26) + 96)
End If
End If
compareDate = wsCurrent.Range(currentCellColumn + CStr(1)).Value
If (compareDate = Null Or compareDate = "") Then
atLastCompareDate = True
Else
If (compareDate = mPDate) Then
Dim cellLocation As String
If (compareDateCounter <= 26) Then
cellLocation = Chr((compareDateCounter) + 96)
Else
If (compareDateCounter > 26) And (compareDateCounter Mod 26 = 0) Then
cellLocation = Chr(Int(compareDateCounter / 26) - 1 + 96) + Chr(122)
Else
cellLocation = Chr(Int(compareDateCounter / 26) + 96) + Chr((compareDateCounter Mod 26) + 96)
End If
End If
wsCurrent.Range(cellLocation + CStr(mPDateCounter)).Interior.ColorIndex = 11
'Loop backwards to mark the 6 dates before
Dim i As Integer
i = compareDateCounter - 1
Do While (i > compareDateCounter - 7)
If (i <= 26) Then
cellLocation = Chr((i) + 96)
Else
If (i > 26) And (i Mod 26 = 0) Then
cellLocation = Chr(Int(i / 26) - 1 + 96) + Chr(122)
Else
cellLocation = Chr(Int(i / 26) + 96) + Chr((i Mod 26) + 96)
End If
End If
wsCurrent.Range(cellLocation + CStr(mPDateCounter)).Interior.ColorIndex = 43
wsCurrent.Range(cellLocation + CStr(mPDateCounter)).Borders.LineStyle = xlContinuous
wsCurrent.Range(cellLocation + CStr(mPDateCounter)).Borders.ColorIndex = 11
i = i - 1
Loop
atLastCompareDate = True
End If
End If
compareDateCounter = compareDateCounter + 1
Loop
End If
mPDateCounter = mPDateCounter + 1
Loop
End Sub