Excel 2007 VBA Find row based on date - excel

Date | data | data | data
12/29| G | F | G
12/30| G | |
I have a spreadsheet like above. I want to find the row that is the current date, then reference the row that is the current date in a Range type. Then cycle through the data in that row.
I can find the current date, and get the address of the cell that is the current date:
dateRange = "A1:" & regionSheet.Range("A1").End(xlDown).Address
For Each cell In regionSheet.Range(dateRange)
If cell.Value = Date Then
row = cell.Address
End If
Next cell
That returns $A$2. I need to somehow turn this into a Range type. I tried using the cell.Address like below:
row = cell.Address & ":" & regionSheet.Range(row).End(xlRight).Address
but that errors out.
Maybe I'm going about this the wrong way? Any ideas?

range(cell, cell.End(xlToRight)).Address
OR
range(cell.Address, range(cell.Address).End(xlToRight)).Address
EDIT: If you want it to have it in Range type, you could use
range(cell, cell.End(xlToRight))

Be warned that the End() function can return incorrect results if there are gaps in the data. For example, if you had data in the second and fourth columns, End will not give you the result you want.
You could try something like this (assumes your data starts in row 1 and column 1):
Sub RowOfCurrentDate()
Dim lngCurrDateRow As Long
Dim lngNumCols As Long
Dim rngDates As Range
Dim rngToday As Range
Dim c As Range
'Get current region and count the number of columns
Set rngDates = Range("A1").CurrentRegion
lngNumCols = rngDates.Columns.Count
'Resize the range down to one column
Set rngDates = rngDates.Resize(rngDates.Rows.Count, 1)
'Find today's date in the range
lngCurrDateRow = Application.WorksheetFunction.Match(CLng(Date), rngDates, 0)
'Set the range to search through for today
Set rngToday = Range(Cells(lngCurrDateRow, 1), Cells(lngCurrDateRow, lngNumCols))
'then loop through all cells in that range
For Each c In rngToday
'if cell is not empty
If Len(c) > 0 Then
'do something
End If
Next c
End Sub

Related

Trying to copy filtered cells and then pasting as value seperating with a comma in a destination cell to create Business Intelligence

My Excel looks like this
Project
Type
Business Intelligence
1001
Apples
1002
Oranges
1003
Oranges
1004
Bananas
1005
Apples
1006
Apples
So when I filter column "B" to have only Apples I want to be able to paste the "1001, 1005" in the Column C (Business Intelligence Column) of the 6th Row (inline with project 1006) to indicate that we have done Apples twice before. The comma between the values is not important, even a space will do
After reading multiple posts, I came across the closest possible solutions for me.
Option Explicit
Sub CopyToY()
Dim ws As Worksheet: Set ws = ActiveSheet ' be more specific
' First Cell of the Data Range (in the row below headers)
Dim fCell As Range: Set fCell = ws.Range("A2")
' Last Cell of the Filtered Range
Dim lCell As Range: Set lCell = ws.Range("A" & ws.Rows.Count).End(xlUp)
' If no filtered data, the last cell will be the header cell, which
' is above the first cell. Check this with:
If lCell.Row < fCell.Row Then Exit Sub ' no filtered data
' Range from First Cell to Last Cell
Dim rg As Range: Set rg = ws.Range(fCell, lCell)
' Filtered Data Range
Dim frg As Range: Set frg = rg.SpecialCells(xlCellTypeVisible)
' Area Range
Dim arg As Range
For Each arg In frg.Areas
arg.EntireRow.Columns("Y").Value = arg.Value ' **this is where it all goes wrong for me - I don't want to paste in column Y but in C6 as "1001, 1005"**
Next arg
MsgBox "Filtered data copied to column ""Y"".", vbInformation
End Sub
Now working towards pasting as value in C6, instead of column Y I found this code.
Sub JoinCells()
Set xJoinRange = Application.InputBox(prompt:="Highlight source cells to merge", Type:=8)
xSource = 0
xSource = xJoinRange.Rows.Count
xType = "rows"
If xSource = 1 Then
xSource = xJoinRange.Columns.Count
xType = "columns"
End If
Set xDestination = Application.InputBox(prompt:="Highlight destination cell", Type:=8)
If xType = "rows" Then
temp = xJoinRange.Rows(1).Value
For i = 2 To xSource
temp = temp & " " & xJoinRange.Rows(i).Value
Next i
Else
temp = xJoinRange.Columns(1).Value
For i = 2 To xSource
temp = temp & " " & xJoinRange.Columns(i).Value
Next i
End If
xDestination.Value = temp
End Sub
But unfortunately this code is taking the invisible filtered rows too. Which means my C6 value is showing as 1001 1002 1003 1004 1005 1006
What I want to do is take the first part of the first code and automatically take the contents of the filtered column A (Project) and then use the second part of the second code to be able to paste the answer "1001, 1005" in C6 (Business Intelligence Column, in line with Project 1006) - This can be done either by highlighting the destination cell OR even better automatically choosing the last visible cell in Column C
I am not a programmer have never learnt coding, I just run my own business - tried my best to get this done but unfortunately am unable to be able to successfully merge these two codes.
Any help would be appreciated.
Maybe you want to try something like this ?
Sub test()
Dim rg As Range
Dim i As Integer
Dim cell As Range
Dim x As String
If ActiveSheet.FilterMode Then
Set rg = Range("B2", Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
If Application.CountA(rg) < 2 Then Exit Sub
i = 0
For Each cell In rg
i = i + 1
If cell.Address = Range("B" & Rows.Count).End(xlUp).Address Then
cell.Offset(0, 1).Value = x
Else
If i = 1 Then x = cell.Offset(0, -1) Else x = x & ", " & cell.Offset(0, -1)
End If
Next
End If
End Sub
The sub above will not automatically run each time you filter the data, as it need to be run manually after you filter the data. The code also doesn't do error checking (for example if you filter the data with a criteria which doesn't exist in the data).
First the code check if the active sheet is filtered, if yes then it
sets the range of the filtered data which visible (the rg variable). If the count of that range is bigger than 1, then the process :
loop to each cell of that range
if it's the first time loop, then it get the value of column A, the looped cell.offset(0,-1) as x variable
if it's not the first time loop, then it will add the value of x with ", " and the value of column A, the looped cell.offset(0,-1).
once the looped cell address is the same with the last row of the visible data of rg, it write the x value to column C in the same row of the last row of the visible data.
Still not sure though if that's what you want. And I wonder if the data will grow or just static. If it will grow, (from your apple example) will there two rows in column C where the last second row contains 1001 and 1005 (the result of the macro before) and the last row contains 1001, 1005 and 1006 ?

Search for string to move one row lower

Sheet contains commission data for employees.
Data is dumped out of Accounting system each week.
Need to move a cell value "Totals" down 1 row to align with the relevant data.
Have tried to search for the string "Totals" then cut and paste 1 row lower.
The string is in col-A. The dataset size and content rows is variable each week but the target string is always in col-A and needs to drop down 1 row, probably with an offset (1, 0) style of command?
Dim m As Integer
m = 2
Do Until m = 300 'this is set to cover the expected occurrences
On Error Resume Next
Range(A1, A300).Cells("m", 0).Find(What:="Totals").Offset(1, 0) = "TOTALS"
m = m + 1
On Error GoTo 0
Loop
Getting no error messages but no results either!
Forget the 'Cut & Paste'. Simply insert a new row at the 'Totals' row.
dim m as variant
m = application.match("totals", range("A:A"), 0)
if not iserror(m) then
rows(m).insert
end if
(and YES you should qualify your parent worksheets!)
So this is what I think you are after. Define the range where the "Totals" lie - assuming they are in a Row? See below code.
Sub LoopTotals()
Dim cell As Range
Dim myRange As Range
'set the range
Set myRange = Sheet1.Range("A1:AA1")
'loop through range
For Each cell In myRange
'check if text is "Totals"
If Trim(cell.Text) = "Totals" Then
'set the new "Totals" 1 row lower
cell.Offset(1, 0).Value = "Totals"
'delete the old string value
cell.ClearContents
End If
Next
End Sub
Additionally, if the "Totals" are pulled in differently each time from the accounting software then you can run a search to find the "Totals" and then you can reference that row number for you range.

Search for a keyword after some filter and return a value in another column

There is a filter applied to my range of data and i would like to search the keyword "abc" in column "I" after the filtering and return a value "Check" at the very end of my data column "W"
I have not know any example to this function but i do had a code before to search for value and delete the row if the amount is 0.
'Delete rows for zero value
Dim LR As Long, i As Long
With Sheets("tempp")
LR = .Cells.Find(What:="0", SearchDirection:=xlPrevious,
SearchOrder:=xlByRows).Row
For i = LR To 1 Step -1
If .Range("C" & i).Value = 0 Then .Rows(i).Delete
Next i
End With
The below code will search your column I. Please adjust the sheet name to your need. It will return the checked status if "abc" is found. If it is not found you can run your desired check where stipulated.
Sub RangeCheck()
Dim myRange As Range
Dim lRowW as Long
'adjust the sheet name to your sheet name
Set myRange = Sheets("Sheet1").Range("I:I").SpecialCells(xlCellTypeVisible).Find(What:="abc")
If Not myRange Is Nothing Then
'found abc, insert checked - presumably the last row of column W?
lRowW = Sheets("Sheet1").Range("W" & Sheets("Sheet1").Rows.Count).End(xlUp).Row
Sheets("Sheet1").Range("W" & lRowW).Value = "Checked"
'if not last row in column W, then use the below
'Sheets("Sheet1").Range("W1").Value = "Checked"
Else
'if it does not find your string "abc" then insert the check you want to run here
End If
'clear object
Set myRange = Nothing
End Sub
You can use something like this:
Dim c As Range
'Going through each visible cell in *I* column. Change 5000 to the numbers of rows your sheet have
For Each c In Worksheets("tempp").Range("I1:I5000").SpecialCells(xlCellTypeVisible)
'Checking if cell contains abc
If InStr(c.Value, "abc") > 0 Then
Worksheets("tempp").Range("W" & c.Row).Value = "Check"
End If
Next
Let us know if it works!

Search a Dynamic Number of rows in Column A for a specific string in VBA

I have a worksheet that contains a varying amount of Rows of data in Column A , within this worksheet I need to search for a specific string then copy the data contained in the Cell adjacent to it and paste into Column C, i.e if data was found in A2 then i need to copy the data from B2 and paste into C1. I can easily find and copy when the string appears once but the string will appear more than once 100% of time. here is when i run into issues.
The temporary code I have written for ease of understanding, searches the spreadsheet for the last Mention of A, get the row number, copy the B cell for that row number then pastes the value into C1.
I guess you need to use range variables for this but not 100% sure how to do it.
i have found no way to copy all mentions of A into a column, or ideally sum up the contents of the B cells. (I can do this, just long winded)
Ive placed my code below.
Sub ValueFinder()
Dim LastALocation As String
Dim ValueContent As String
LastALocation = Range("A:A").Find(What:="A", after:=Range("A1"), searchdirection:=xlPrevious).Row
ValueContent = Cells(LastALocation, 2)
Cells(1, 3) = ValueContent
End Sub
The spreadsheet that its using for more information, contains A,B,C on a loop in Column A and the odd numbers in Column B.
Thanks for any help your able to provide.
Mark
This will look for a string in Column A, and add to Column C the same row's B Column Value.
Sub find_move()
Dim foundCel As Range
Dim findStr As String, firstAddress As String
Dim i As Long
i = 1
findStr = "A"
Set foundCel = Range("A:A").Find(what:=findStr)
If Not foundCel Is Nothing Then
firstAddress = foundCel.Address
Do
Range("C" & i).Value = foundCel.Offset(0, 1).Value
Set foundCel = Range("A:A").FindNext(foundCel)
i = i + 1
Loop While Not foundCel Is Nothing And foundCel.Address <> firstAddress
End If
End Sub
Note: You should add the worksheet in front of all the range values, i.e. Sheets("Sheet1").Range("A:A").Find(...
Consider:
Sub LookingForA()
Dim s As String, rng As Range, WhichRows() As Long
Dim rFound As Range
ReDim WhichRows(1)
s = "A"
Set rng = Range("A:A")
Set rFound = rng.Find(What:=s, After:=rng(1))
WhichRows(1) = rFound.Row
Cells(1, 3) = Cells(rFound.Row, 2)
Do
Set rFound = rng.FindNext(After:=rFound)
If rFound.Row = WhichRows(1) Then Exit Do
ReDim Preserve WhichRows(UBound(WhichRows) + 1)
WhichRows(UBound(WhichRows)) = rFound.Row
Cells(Cells(Rows.Count, "C").End(xlUp).Row + 1, 3) = Cells(rFound.Row, 2)
Loop
End Sub
This code builds column C. It also builds an internal array of the row numbers in the event they are needed later.
EDIT#1:
To read about dynamic arrays:
Dynamic Arrays
or Google:
Excel VBA dynamic array

I can't get my VBA Excel Macro to stop at the end of the row

I have a row of data that changes once a month but it only changes roughly 30 cells out of 90 and every month they are different so I am trying to make a Macro to automate it.
The Macro looks at Cells A2 - B98 and searches for information that matches the Values of H2-I98 and if the values in A match H then it copies what the value is in I and replaces it in B but it doest stop at the end of the row i.e. at row 98 it loops infinatly. So I was hoping someone could find my error so that it wont loop for ever. Thanks
Sub Update_Holiday()
Dim Search As String
Dim Replacement As String
Dim rngTmp As Range
Dim rngSearch As Range
LastInputRow = Range("A65536").End(xlUp).Row
Set rngSearch = Worksheets("Holiday").Range(Cells(2, 1), Cells(98, 2))
For k = 2 to 98
Search = Worksheets("Holiday").Cells(k, 8)
Replacement = Worksheets("Holiday").Cells(k, 9)
With rngSearch
Set rngTmp = .Find(Search, LookIn:=xlValues)
If rngTmp Is Nothing Then
GoTo Go_to_next_input_row:
Else
Worksheets("Holiday").Cells(rngTmp.Row, rngTmp.Column + 1).Value = Replacement
End If
End With
Go_to_next_input_row:
Next K
End Sub
If I understand your question correctly: for each Cell in H2:H98, you're looking for a match in A2:A98. It won't necessarily be on the same row. If you find a match in Column A, you want to take the value from Column B and put it in Column I on the same row as the search value we just looked for. In this case, this code will work:
Option Explicit
Sub Test()
Dim ws As Worksheet
Dim srcRng As Range '' Source range
Dim schRng As Range '' Search range
Dim c As Range
Dim search As Range
Set ws = ThisWorkbook.Sheets(1)
Set srcRng = ws.Range("H2:H98")
Set schRng = ws.Range("A2:A98")
For Each c In srcRng '' Iterate through your source range
Set search = schRng.Find(c.Value, LookIn:=xlValues, SearchDirection:=xlNext) '' Find the value from column H in column A
If Not search Is Nothing Then
c.Offset(, 1).Copy search.Offset(, 1) '' Get the value from column B, from the same row as the value it found in column A
'' Then paste that value in column I, on the same row as the value we searched for from column H
End If
Next c
GoTo statements are generally (generally, not always) very, very bad practice. Especially in this kind of situation. You don't need them, it just makes your code convoluted.

Resources