Struggling with this counter...
I am going through multiple pages of info and trying to count the number of overdue tasks then inserting this info into a statistics page.
Sub data_input_overdue()
Dim rw As Long
Dim Counter As Long
Dim col As Long
col = CountMyCols("Stats")
Worksheets("Stats").Cells(2, col + 1).Value = "Overdue"
Counter = 0
For Each sht In ThisWorkbook.Sheets
For i = 2 To CountMyRows(sht.Name)
c_date = Range("E" & i)
dueDate = CDate(c_date)
If dueDate < Date And sht.Range("I" & i).Value = "No" Then
Counter = Counter + CLng(1)
Worksheets("Stats").Cells(i, col + 1).Value = Counter
End If
Next i
Next sht
End Sub
Public Function CountMyRows(SName As String) As Long
On Error Resume Next
With ThisWorkbook.Worksheets(SName)
CountMyRows = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
Its not counting and going into the right places in the table as well. I want it to go into a column starting on the 3rd row.
In the multiple sheets there is a mixture of completed and uncompleted tasks
I think this is what you are trying to do, but I'm not sure how you will identify each total with the applicable sheet.
Sub data_input_overdue()
Dim c_date
Dim dueDate As Date
Dim i As Long
Dim Counter As Long
Dim cntSheet As Long
Dim col As Long
col = CountMyCols("Stats")
Worksheets("Stats").Cells(2, col + 1).Value = "Overdue"
cntSheet = 0
For Each sht In ThisWorkbook.Worksheets
If sht.Name <> "Stats" Then ' Don't process the Stats sheet
cntSheet = cntSheet + 1
'Reset counter at the start of each sheet
Counter = 0
For i = 2 To CountMyRows(sht.Name)
c_date = sht.Range("E" & i)
dueDate = CDate(c_date)
If dueDate < Date And sht.Range("I" & i).Value = "No" Then
Counter = Counter + 1
End If
Next i
'Update Stats sheet after finished counting
Worksheets("Stats").Cells(2 + cntSheet, col + 1).Value = Counter
End If
Next sht
End Sub
Public Function CountMyRows(SName As String) As Long
On Error Resume Next
With ThisWorkbook.Worksheets(SName)
CountMyRows = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End With
End Sub
Public Function CountMyCols(SName As String) As Long
On Error Resume Next
With ThisWorkbook.Worksheets(SName)
CountMyCols = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
End With
End Sub
If I was doing this, I would probably put the sheet names in column A and the totals in column B, or start with the sheet names in column A, and then use that sheet name to decide which sheet to process when calculating the total to put on that row (rather than just looping through all the sheets in tab order).
Related
I've written the following code where i want to find the value "BEST Cards Raised:" in column B and where ever this value is delete this and all subsequent rows with data in column B.
I thought what i've written would work but its currently deleting all rows and I cant figure it out :(
Dim lastRow As Long, found As Range
With ActiveSheet
Set found = .Range("B1:B" & .Cells(.Rows.Count, "B").End(xlUp).Row).Find("BEST Cards Raised:")
If Not found Is Nothing Then
lastRow = .Cells.Find(What:="*", _
After:=.Cells(1, 1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
If lastRow >= found.Row Then
Debug.Print .Rows(found.Row & ":" & lastRow).EntireRow.Delete
End If
End If
End With
If also deleting the row where found then perhaps try the following:
Option Explicit
Public Sub DeleteRows()
Dim lastRow As Long, found As Range
With ThisWorkbook.Worksheets("Sheet1") '<your sheet
Set found = .Range("B1:B" & .Cells(.Rows.Count, "B").End(xlUp).Row).Find("BEST Cards Raised:")
If Not found Is Nothing Then
lastRow = .Cells.Find(What:="*", _
After:=.Cells(1, 1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
If lastRow >= found.Row Then
.Rows(found.Row & ":" & lastRow).EntireRow.Delete
End If
End If
End With
End Sub
Post debugging
Dim lastRow As Long, foundRow As Variant
With ThisWorkbook.Worksheets("Sheet8")
lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
foundRow = Application.Match("BEST Cards Raised:", .Range("B1:B" & lastRow), 0)
If IsError(foundRow) Then Exit Sub
If lastRow >= foundRow Then .Rows(foundRow & ":" & lastRow).EntireRow.Delete
End With
Try this (comments in code):
Sub DeleteRows()
Dim ws As Worksheet, lastRow As Long, i As Long, j As Long
Set ws = ThisWorkbook.Worksheets("Sheet1")
lastRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
'determine where to start deleting rows
For i = 1 To lastRow
If Trim(ws.Cells(i, 2).Value) = "BEST Cards Raised:" Then Exit For
Next
'delete all rows from last to found row, looping backwards
For j = lastRow To i Step -1
ws.Rows(j).Delete
Next
End Sub
I have an userform designed with three listbox. The list box are populated from sheets, List_Dev_Red,List_Man_Red,List_SQM_Red. in my userform activate , I get an error "Method or data member" not found in the below line
For xRow = 2 To Last(1, List_Dev_Red.Range("A:A"))
Could any one tel me what could be the reason for this error.
Private Sub UserForm_Activate()
Dim xRow As Integer
Dim yRow As Integer
Dim zrows As Integer
For xRow = 2 To Last(1, List_Dev_Red.Range("A:A"))
With LB1
.AddItem List_Dev_Red.Cells(xRow, 3).Value
If List_Dev_Red.Cells(xRow, 2) = True Then
.Selected(xRow - 2) = True
Else
.Selected(xRow - 2) = False
End If
End With
Next xRow
LB1.Height = (xRow - 1) * 15
For yRow = 2 To Last(1, List_Man_Red.Range("A:A"))
With LB2
.AddItem List_Man_Red.Cells(yRow, 3).Value
If List_Man_Red.Cells(yRow, 2) = True Then
.Selected(yRow - 2) = True
Else
.Selected(yRow - 2) = False
End If
End With
Next yRow
LB2.Height = (yRow - 1) * 15
For zrows = 2 To Last(1, List_SQM_Red.Range("A:A"))
With LB3
.AddItem List_SQM_Red.Cells(zrows, 3).Value
If List_SQM_Red.Cells(zrows, 2) = True Then
.Selected(zrows - 2) = True
Else
.Selected(zrows - 2) = False
End If
End With
Next zrows
LB3.Height = (zrows - 1) * 15
End Sub
Function Last (from RondeBruin):
Function Last(choice As Long, rng As Range)
' 1 = last row
' 2 = last column
' 3 = last cell
Dim lrw As Long
Dim lcol As Long
Select Case choice
Case 1:
On Error Resume Next
Last = rng.Find(What:="*", _
After:=rng.Cells(1), _
LookAt:=xlWhole, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
Case 2:
On Error Resume Next
Last = rng.Find(What:="*", _
After:=rng.Cells(1), _
LookAt:=xlWhole, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
Case 3:
On Error Resume Next
lrw = rng.Find(What:="*", _
After:=rng.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
On Error Resume Next
lcol = rng.Find(What:="*", _
After:=rng.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
On Error Resume Next
Last = rng.Parent.Cells(lrw, lcol).Address(False, False)
If Err.Number > 0 Then
Last = rng.Cells(1).Address(False, False)
Err.Clear
End If
On Error GoTo 0
End Select
End Function
You need to change your syntax a bit (at the upper section of your code):
Dim xRow As Long
Dim yRow As Long
Dim zrows As Long
Dim LastRow As Long ' <-- change all variables to Long (be on the safe side)
' get the last row by calling your Last function
LastRow = Last(1, List_Dev_Red.Range("A:A")) ' <-- you are passing a Range, and want to get a Long, representing the row number
' loop through your rows
For xRow = 2 To LastRow
' rest of your code
Next xRow
and make the change to your Function to return a Long (row number):
Function Last(choice As Long, rng As Range) As Long
In general, concerning that you know that you are looking for either column or row, you may use simplified functions like these:
Option Explicit
Function LastRow(sh As Worksheet) As Long
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function LastCol(sh As Worksheet) As Long
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
They are from the same site as the Variant function.
Option Explicit
'***** VARIABLES *****
Public wbI As Workbook, wsChess As Worksheet
Public blackPlayer As cPlayer, whitePlayer As cPlayer
Public txtB_bPlayerName As TextBox, txtB_wPlayerName As TextBox
Public Sub initVars()
Set wbI = ThisWorkbook
Set wsChess = wbI.Sheets(1)
'Works
ThisWorkbook.Sheets(1).txtB_bPlayerName.Value = ""
'Don't work
wsChess.txtB_wPlayerName.Value = ""
End Sub
STILL really bad at vba....
1) I am trying to count the number of overdue tasks. At the moment it is not counting.
2) when i press f5 even though I have erased all the info in the page it goes to the next column
eg If i erased column 1 it will go to column 2 even though there is no info in column 1.
Sub data_input_overdue()
Dim rw As Long
Dim Counter As Long
Dim col As Long
col = CountMyCols("Stats")
Worksheets("Stats").Cells(2, col + 1).Value = "Overdue"
Counter = 0
For Each sht In ThisWorkbook.Sheets
For i = 2 To CountMyRows(sht.Name)
c_date = Range("E" & i)
dueDate = CDate(c_date)
If dueDate < Date And sht.Range("I" & i).Value = "No" Then
Counter = Counter + CLng(1)
Worksheets("Stats").Cells(i, col + 1).Value = Counter
End If
Next i
Next sht
End Sub
Function CountMyCols(SName As String) As Long
CountMyCols = ThisWorkbook.Worksheets(SName).UsedRange.Columns.Count
End Function
A replacement CountMyCols function might be:
Public Function CountMyCols(SName As String) As Long
On Error Resume Next
With ThisWorkbook.Worksheets(SName)
CountMyCols = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
End With
End Function
This has been based on one of the examples in the now-retired StackOverflow Documentation:
Private Sub Get_Last_Used_Row_Index()
Dim wS As Worksheet
Set wS = ThisWorkbook.Sheets("Sheet1")
Debug.Print LastCol_1(wS)
Debug.Print LastCol_0(wS)
End Sub
You can choose between 2 options, regarding if you want to know if there is no data in the worksheet :
NO : Use LastCol_1 : You can use it directly within wS.Cells(...,LastCol_1(wS))
YES : Use LastCol_0 : You need to test if the result you get from the function is 0 or not before using it
Public Function LastCol_1(wS As Worksheet) As Double
With wS
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
LastCol_1 = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
Else
LastCol_1 = 1
End If
End With
End Function
The Err object's properties are automatically reset to zero upon function exit.
Public Function LastCol_0(wS As Worksheet) As Double
On Error Resume Next
LastCol_0 = wS.Cells.Find(What:="*", _
After:=ws.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
End Function
I have a excel sheet containing multiple cells with a string foo in the first row. I want to find the first and last column in which the string is written. I have tried the following
Dim first_col As Integer
Dim last_col As Integer
Dim col As Integer
Dim found As Range
Dim ws_MLB as Worksheet
Dim foo as String
set ws_MLB = ThisWorkbook.Sheet(1)
Set found = ws_MLB.Rows(1).Find(foo)
If Not found Is Nothing Then
col = found.Column
first_col = col
last_col = col
Do
found = ws_MLB.Rows(1).FindNext(found)
col = found.Column
If col < first_col Then
first_col = col
MsgBox ("This should not happen")
ElseIf col > last_col Then
last_col = col
End If
Loop While Not found Is Nothing And col <> first_col
Else
MsgBox ("not found")
End If
But this way I only get the the first value for both first_col and last_col. When I search for the string with the integrated excel search I find multiple instances. So the string is there. Have I done a mistake or is there a better way to do this?
edit forgot to mention that I also tried to change the search direction, but I still got the first entry.
You can make this a lot easier by using the SearchDirection Parameter in .Find by using xlNext you search Left to Right then xlPrevious searches Right to Left.
Sub FindFL()
Dim wbk As Workbook
Dim ws As Worksheet
Dim fColumn As Long, lColumn As Long
Set wbk = ThisWorkbook 'Change this to your workbook
Set ws = wbk.Worksheets("Sheet1") 'Change this to your worksheet
With ws
'Find first column that foo shows up
fColumn = .Cells.Find(What:="foo", _
After:=.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False).Column
'Find last column that foo shows up
lColumn = .Cells.Find(What:="foo", _
After:=.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
Debug.Print "First Column is " & fColumn; vbNewLine _
; "Last Column is " & lColumn
End With
End Sub
I would do that like this:
Public Sub foo()
Dim nCol As Integer
Dim nFirst As Integer
Dim nLast As Integer
With ActiveSheet
nCol = 1
Do Until .Cells(1, nCol) = ""
If .Cells(1, nCol) = "foo" Then
If nFirst = 0 Then
nFirst = nCol
Else
nLast = nCol
End If
End If
nCol = nCol + 1
Loop
End With
MsgBox "First: " & nFirst & vbCr & "Last: " & nLast
End Sub
I am currently trying to write some VBA code which will fill out all cells between two cells with the value of the two cells.
Here is what I have :
And I would like the code to fill out all cells in between like this:
So, as you can see I would like all the cells in between to be filled out with the same value as the two corner cells.
Any help is very much appreciated! Thanks in advance.
you could use SpecialCells() method of Range object:
Sub main()
Dim cell As Range
For Each cell In Intersect(Columns(1), ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants).EntireRow)
With cell.EntireRow.SpecialCells(xlCellTypeConstants)
Range(.Areas(1), .Areas(2)).Value = .Areas(1).Value
End With
Next
End Sub
Place this in a new module and run test_DTodor:
Option Explicit
Sub test_DTodor()
Dim wS As Worksheet
Dim LastRow As Double
Dim LastCol As Double
Dim i As Double
Dim j As Double
Dim k As Double
Dim RowVal As String
Set wS = ThisWorkbook.Sheets("Sheet1")
LastRow = LastRow_1(wS)
LastCol = LastCol_1(wS)
For i = 1 To LastRow
For j = 1 To LastCol
With wS
If .Cells(i, j) <> vbNullString Then
'1st value of the row found
RowVal = .Cells(i, j).Value
k = 1
'Fill until next value of that row
Do While j + k <= LastCol And .Cells(i, j + k) = vbNullString
.Cells(i, j + k).Value = RowVal
k = k + 1
Loop
'Go to next row
Exit For
Else
End If
End With 'wS
Next j
Next i
End Sub
Public Function LastCol_1(wS As Worksheet) As Double
With wS
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
LastCol_1 = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
Else
LastCol_1 = 1
End If
End With
End Function
Public Function LastRow_1(wS As Worksheet) As Double
With wS
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
LastRow_1 = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
LastRow_1 = 1
End If
End With
End Function