I have been tasked with creating a way for a column of data to update the most recent entry to cell at the bottom. More specifically a loan portfolio amount is entered in for each month of this year and the most recent entry needs to also appear at the bottom of the column. Here's what I initally came up with but this won't work for the last entry before the bottom.
Private Sub Worksheet_Change(ByVal Target As Range)
xC = 0
yC = 7
If (Target.Column = 3) Then
Do
prevInt = currentInt
currentInt = Sheet1.Cells(yC, 3).Value
If (currentInt = 0) Then
Sheet1.Cells(19, 3).Value = prevInt
xC = 1
End If
yC = yC + 1
Loop Until xC = 1
End If
End Sub
i assume the cells below the most current month's total will always be blank, unless it's December. Otherwise i don't know how you'll know which is the most current:
Public Sub SetTotalCellValue()
Const portfolioColumn As Integer = 3
Const endRow As Integer = 14 'row of "total" cell
Dim sheet As Worksheet
Dim rowCount As Integer
Dim val As Object
rowCount = 2 'start at January, skip header row
'Set sheet = some sheet
'find last empty cell
For a = 1 To endRow
If sheet.Cells(a, portfolioColumn).Value = Empty Then
sheet.Cells(endRow, portfolioColumn).Value = sheet.Cells(a - 1, portfolioColumn).Value
Exit For
ElseIf a = endRow - 1 Then
sheet.Cells(endRow, portfolioColumn).Value = sheet.Cells(a, portfolioColumn).Value
Exit For
End If
Next a
End Sub
Related
I have a basic userform and need the one textbox to increment the number on the Add/next command, which I get right until you at the "PO" prefix.
I am doing a basic PO entry userform that adds info into the "Entries" sheet. The PO number has a "PO" prefix when clicking the add command I am trying to get the number to increment.
Dim currentrow As Long
Dim NextNum As Long
Dim prefix As String
Dim i As Long
Private Sub frmPurchaseOrder_Initialize()
currentrow = 2
End Sub
Private Sub cmdAdd_Click()
Dim num As Integer
'to check the last filled row
lastrow = ThisWorkbook.Worksheets("Entries").Cells(Rows.Count, 1).End(xlUp).Row
ThisWorkbook.Worksheets("Entries").Cells(lastrow + 1, 1).value = txtDocNo.Text
ThisWorkbook.Worksheets("Entries").Cells(lastrow + 1, 2).value = txtLineNumber.Text
ThisWorkbook.Worksheets("Entries").Cells(lastrow + 1, 3).value = txtDocType.Text
'next one
Me.txtDocType = "PO"
Me.txtLine = Me.txtLine + 1
End Sub
Private Sub UserForm_Initialize()
currentrow = 2
Me.txtInvoiceDate = Date
Me.txtDocType = "PO"
Me.txtLine = "1"
Me.txtDocNo = Application.WorksheetFunction.max(Range("DocNoList")) + 1
End Sub
The DocNo is in the first column on the entries sheet, range named "DocNoList"
I would appreciate your help.
Since you have the "PO" prefix in front of all the document numbers the Max function doesn't work. It would seem to be easiest to just access the last row of your data and extract the numeric value from that. Replace this line
Me.txtDocNo = Application.WorksheetFunction.max(Range("DocNoList")) + 1
with
With ThisWorkbook.Worksheets("Entries").Cells(Rows.Count, 1).End(xlUp)
Me.txtDocNo.Value = Me.txtDocType.Value + CInt(Right(.Value2, Len(.Value2) - 2)) + 1
End With
Alternatively:
Dim strDocNo As String
strDocNo = ThisWorkbook.Worksheets("Entries").Cells(Rows.Count, 1).End(xlUp).Value2
Me.txtDocNo.Value = Me.txtDocType.Value + CInt(Right(strDocNo, Len(strDocNo) - 2)) + 1
So i found this script on this site to color rows with the same cell-data and change the color when the celldata changes and it seems to work just fine, but i have two minor issues
It seems to only apply to the first 900 rows (I have an excel list with 8000+ rows)
It colors the entire row, is there a way to make it only color a certain part of the row?
Thanks in advance! here's the script:
Public Sub HighLightRows()
Dim i As Integer
i = 2 'start at 2, cause there's nothing to compare the first row with
Dim c As Integer
c = 2 'Color 1. Check http://dmcritchie.mvps.org/excel/colors.htm for color indexes
Do While (Cells(i, 1) <> "")
If (Cells(i, 1) <> Cells(i - 1, 1)) Then 'check for different value in cell A (index=1)
If c = 2 Then
c = 37 'color 2
Else
c = 2 'color 1
End If
End If
Rows(Trim(Str(i)) + ":" + Trim(Str(i))).Interior.ColorIndex = c
i = i + 1
Loop
End Sub
Try this:
Public Sub HighLightRows()
Const START_ROW As Long = 2 '<< use a Constant for fixed values
Const VALUE_COL As Long = 1
Dim rw As Range, emptyCells As Long, i As Long, currentValue, tmp
Dim arrColors
arrColors = Array(37, 2)
Set rw = ActiveSheet.Rows(START_ROW)
currentValue = Chr(0) 'dummy "current value"
Do While emptyCells < 10 'quit after 10 consecutive empty cells
tmp = rw.Cells(VALUE_COL).Value
If Len(tmp) > 0 Then
If tmp <> currentValue Then
i = i + 1
currentValue = tmp 'save the new value
End If
'assign the color to a specific set of cells in the row
' starting at cell 1 and 5 columns wide
rw.Cells(1).Resize(1, 5).Interior.ColorIndex = arrColors(i Mod 2)
emptyCells = 0 'reset empty row counter
Else
emptyCells = emptyCells + 1 'increment empty row counter
End If
Set rw = rw.Offset(1, 0) 'next row
Loop
End Sub
It looks like the code only evaluates if the cell is the same as the cell above it. Conditional formatting, as John Coleman said, would be more effective. With it values in the whole column can be evaluated instead of just adjacent ones. And, if I'm not mistaken, there's a setting to look for dup values since Excel 2007, so there doesn't have to be some kind of formula kung-fu to do it.
Unless I'm missing something, it's as simple as Conditional Formatting -> Highlight Cell Rules -> Duplicate Values.
I have made a userform, but I can't manage to fill the data from it to the next row every time, it always fills the same row.
Here is my current code:
Private Sub btnivesti_Click()
Dim ssheet As Worksheet
Set ssheet = ThisWorkbook.Sheets("Lapas1")
ssheet.Cells(3) = CDate(Me.tddate)
ssheet.Cells(1) = Me.cmblistitem
ssheet.Cells(4) = Me.tbpo
ssheet.Cells(6) = Me.tbkodas
ssheet.Cells(8) = Me.tbkiekis
End Sub
Private Sub UserForm_Initialize()
Me.tddate = Date
'fill drop box
For Each cell In [listas1]
Me.cmblistitem.AddItem cell
Next cell
End Sub
Your current code references the cell number. Cell number determines cell location by counting the number of cells individually (Row 1 would have cell numbers from 1 to 16384, Row 2 from 16385 to 32768, etc.), which is highly inefficient. Instead, you should reference the row and column where you want to put your data.
Since you want to fill new data to new rows, get the location of the last row with data on it and increment by 1. Try this:
Private Sub btnivesti_Click()
Dim ssheet As Worksheet
Dim lastrow as Integer
Set ssheet = ThisWorkbook.Sheets("Lapas1")
lastrow = Range("A" & Rows.Count).End(xlUp).Row + 1
ssheet.Cells(lastrow, 3) = CDate(Me.tddate)
ssheet.Cells(lastrow, 1) = Me.cmblistitem
ssheet.Cells(lastrow, 4) = Me.tbpo
ssheet.Cells(lastrow, 6) = Me.tbkodas
ssheet.Cells(lastrow, 8) = Me.tbkiekis
End Sub
wk2LastRow = wk2.Cells(Rows.Count, 1).End(xlUp).Row
i = 2
For wk2Range = 2 To wk2LastRow
id = wk2.Cells(wk2Range, 1)
Set f = wk1.Range("A2:I7").Find(id, , xlValues, xlPart)
'Conditional Statement code to be inserted here
Next wk2Range
Background information:
Search values are in Worksheet 2 (wk2).
wk2Range selects the entire search value
"A2:I7" are the values below from 1 to 6
I want to match a list of values to the "A2:I7" (1 to 6). The data that I need from the table is the second OFF day's Date. For example, For name 2, the second off day dates are 01/02/15, 01/06/15.
I want the code to find a match, afterwards read the code horizontally to find the second off day, and then end(xlup) to get the date.
I have thought of the 4 possible scenarios but am unsure of how to write them down into code. I just need the second off days date, the code can ignore the rest of the variations.
On On Off Off
On Off Off On
Off Off On On
Off On On Off
Please see picture for elaboration:
This is not the most elegant solution but should return the dates you are hoping for:
Private Sub ViewHolidayDates()
'Defined rota range:
Set Rota = Sheet1.Range("B2:I7").Cells
'How many dates across.
Dim RowLength As Integer: RowLength = 8
'Which Name we are looping.
Dim Row As Integer: Row = 1
'Where within the range loop we are.
Dim UserRecord As Integer: UserRecord = 0
'Current count of "off" for current Row.
Dim Holiday As Integer: Holiday = 0
Dim DateValue As String
For Each Record In Rota
If Record = "off" Then
Holiday = Holiday + 1
If Holiday = 2 Then
DateValue = Sheet1.Range("B2").Offset(-1, UserRecord).Value
MsgBox (DateValue)
'reset Holiday counter:
Holiday = 0
End If
End If
UserRecord = UserRecord + 1
If UserRecord = RowLength Then
'Reset counters ready for new "Name"
Row = Row + 1
UserRecord = 0
Holiday = 0
End If
Next Record
End Sub
Please set the Rota variable in my code to the range in your Excel Sheet and also the Sheet1.Range("B2") in my code to be the first record in your range.
UPDATE:
You can adjust the RowLength and the If Holiday = 2 to values more suited to your scenario. You should also note "off" is case sensitive.
UPDATE
I have updated the Holiday counter to reset within the IF statement, this will then return a date for each instance of the second "off".
Also, my Row - Row - 1 was not required, as the range I defined was fixed: Sheet1.Range("B2") we need only to say Offset(-1, UserRecord) and dynamically pass in how many columns across we expect the date to be.
Here's one way to do it, just assign SecondOff to the range of your choice in the calling sub. Note that there are probably better ways to do it than with Find, but I wanted to stay in sync with your question.
Public Function SecondOff(Schedule As Range) As Variant
Dim rw As Range, Temp As Variant
Dim i As Integer, j As Integer
Dim wrow As Integer, firstI As Integer, origI As Integer
ReDim Temp(1 To 6, 1 To 9)
For Each rw In Schedule.Range("2:" & Schedule.Rows.Count).Rows
i = 1
j = 2
wrow = rw.Cells(1, 1)
Temp(wrow, 1) = wrow
If (rw.Find("off", rw.Cells(1, i), xlValues, xlPart) Is Nothing) Then
Temp(wrow, 2) = "None"
Else
origI = rw.Find("off", rw.Cells(1, i), xlValues, xlPart).Column
Do
firstI = rw.Find("off", rw.Cells(1, i), xlValues, xlPart).Column
If firstI <= origI And j > 2 Then Exit Do
i = rw.Find("off", rw.Cells(1, firstI), xlValues, xlPart).Column
If i <= origI Then Exit Do
If i - firstI = 1 Then
Temp(wrow, j) = Schedule(1, i)
j = j + 1
Else
i = firstI
End If
Loop Until j > 8
End If
Next rw
SecondOff = Temp
End Function
I have a spreadsheet which looks like this:
Name Task Date
Mike Go to the beach 10/1/13
Mike Go Shopping 10/2/13
Mike Go to work 10/3/13
Bill Go Hiking 10/1/13
Bill Go to work 10/3/13
I am trying to build another tab to the spreadsheet which will look at the data tab and return the matching text value when the rows and the columns match.
I'm trying to use a formula create a type of pivot table.
The results should look like this:
Name 10/1/13 10/2/13 10/3/13
Mike Go to the beach Go shopping Go to work
Bill Go Hiking *Blank* Go to work
I tried to post images but couldn't since this is my first post.
I hope you can understand what I am asking.
I am no expert in Pivot Tables, I have done it the dumb way - but works. Assumptions:
1) Source Data always on "Sheet1" with those 3 column headers
2) The "Sheet2" will be used to store sorted data
Sub SO_19105503()
Const NameCol As Long = 1
Const TaskCol As Long = 2
Const DateCol As Long = 3
Dim oShSrc As Worksheet, oShTgt As Worksheet, R As Long, C As Long
Dim aNames As Variant, aDates As Variant
Dim lNames As Long, lDates As Long
Dim oRng As Range, oArea As Range
Set oShSrc = ThisWorkbook.Worksheets("Sheet1") ' Source worksheet with original data
oShSrc.Copy Before:=oShSrc
Set oShSrc = ThisWorkbook.Worksheets("Sheet1 (2)") ' Copy of Source worksheet
Set oShTgt = ThisWorkbook.Worksheets("Sheet2") ' Target worksheet to store sorted data
oShSrc.AutoFilterMode = False
' Get unique names (sorted) in column A
aNames = Array()
lNames = 0
R = 1
oShSrc.UsedRange.Sort Key1:=oShSrc.Cells(R, NameCol), Header:=xlYes
Do
R = R + 1
If Not IsEmpty(oShSrc.Cells(R, NameCol)) And oShSrc.Cells(R, NameCol).Value <> oShSrc.Cells(R - 1, NameCol).Value Then
ReDim Preserve aNames(lNames)
aNames(lNames) = oShSrc.Cells(R, NameCol).Value
lNames = lNames + 1
End If
Loop Until IsEmpty(oShSrc.Cells(R, NameCol))
' Get unique dates (sorted) in column C
aDates = Array()
lDates = 0
R = 1
oShSrc.UsedRange.Sort Key1:=oShSrc.Cells(R, DateCol), Header:=xlYes
Do
R = R + 1
If Not IsEmpty(oShSrc.Cells(R, DateCol)) And oShSrc.Cells(R, DateCol).Value <> oShSrc.Cells(R - 1, DateCol).Value Then
ReDim Preserve aDates(lDates)
aDates(lDates) = oShSrc.Cells(R, DateCol).Value
lDates = lDates + 1
End If
Loop Until IsEmpty(oShSrc.Cells(R, DateCol))
' Prepare and put data to Target sheet
oShTgt.Range("A1").Value = oShSrc.Range("A1").Value ' Name
' Insert Dates (start from column B on Row 1)
For C = 0 To lDates - 1
oShTgt.Cells(1, C + 2).Value = aDates(C)
Next
' Insert Names (start from Row 2 on Column A)
For R = 0 To lNames - 1
oShTgt.Cells(R + 2, 1).Value = aNames(R)
Next
' Reprocess the source data with Autofilter
For R = 0 To lNames - 1
oShSrc.AutoFilterMode = False ' Remove AutoFilter before apply
' Apply AutoFilter with Criteria of R'th entry in array aNames
oShSrc.UsedRange.AutoFilter Field:=1, Criteria1:="=" & aNames(R)
' Go through Ranges in each Area
For Each oArea In oShSrc.Cells.SpecialCells(xlCellTypeVisible).Areas
For Each oRng In oArea.Rows
' Stop checking if row is more than used
If oRng.Row > oShSrc.UsedRange.Rows.count Then
Exit For
End If
' Check only if the row is below the header
If oRng.Row > 1 Then
For C = 0 To lDates - 1
' Find the matching date and put the "Task" value
If oShSrc.Cells(oRng.Row, DateCol).Value = aDates(C) Then
oShTgt.Cells(R + 2, C + 2).Value = oShSrc.Cells(oRng.Row, TaskCol).Value
Exit For
End If
Next C
End If
Next oRng
Next oArea
Next R
Application.DisplayAlerts = False
oShSrc.Delete ' Delete the temporary data source sheet
Application.DisplayAlerts = True
Set oShSrc = Nothing
Set oShTgt = Nothing
End Sub
Screenshots - Source Data/Result: