I found a code but I don't why it is not working, I'm barely new to VBA. Please help me..
What I am trying to achieve is I need to Search the day today from another wb.
Here's my complete code:
Sub Sample
Sheets("Database").Select
Dim i as Workbook
Dim c as Workbook
Set i = Workbooks("Workbook1.xlsm")
Set c = Workbooks.Open(FileName:=Range("U2").Value)
'U2 contains the link or path of the file.
ThisWorkbook.Activate
Sheets("Summary").Activate
Windows("Workbook1").Activate
Sheets("Database").Select
Workbooks(2).Activate
Sheets("Summary").Select
Dim FindString As Date
Dim Rng As Range
FindString = CLng(Date)
With Sheets("Summary").Range("A:A")
Set Rng = .Find(What:=FindString, After:=.Cells(.Cells.Count), LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlbyColumns, SearchDirection;=xlNext,MatchCase;=False)
If Not Rng Is nothing then
Application.Goto Rng, True
Else
Msgbox "Nothing Then"
End if
End with
End Sub
The other workbook that was recently opened contains Summary Sheet that has Dates on Column A:A
If you're getting a syntax error - the two parameters are defined with semi-colons ";" instead of colons ":"
SearchDirection;=xlNext,MatchCase;=False
becomes
SearchDirection:=xlNext,MatchCase:=False
Fix your syntax before testing - Use Debug | Compile
Activating and Selecting is not necessary and harmful
There are also some syntax errors
You may want to re-start from the following code:
Sub Sample
Dim dbSheet as Worksheet
Dim Rng As Range
Set dbSheet = Workbooks("Workbook1.xlsm").Sheets("Database") 'set the “database” worksheet
With Workbooks.Open(FileName:=dbSheet.Range("U2").Value).Sheets("Summary") 'open the workbook whose link is in “database” sheet cell U2 and reference its “Summary” sheet
With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)) ' reference referenced sheet column A cells from row 1 down to last not empty row
Set Rng = .Find(What:=CLng(Date), After:=.Cells(.Rows.Count), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False) ' try finding current date starting from the cell at the top of referenced range
End With
End With
If Not Rng Is nothing then
Application.Goto Rng, True
Else
Msgbox "Nothing Then"
End if
End Sub
This code is untested but from the explanations in comments you can tweak it to reach the goal
Related
I am having an issue with a piece of VBA in excel and am looking for assistance.
I require a piece of code to auto populate a formula in excel through a series of data, the series will vary in length and will occupy columns C:I.
I have been using this piece of code without issue for quiet a while:
Sub Auto_Fill_Formula()
Sheets("Sheet1").Select
Dim LstRow As Long
With Sheets("Sheet1")
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("A2:A" & LastRow).Formula = "Formula added here"
Application.CutCopyMode = False
End With
End Sub
However as the formula is being added to the leftmost column it only populates the first cell, cell A2.
How can I modify this code to work when the leftmost column is empty?
Thank you,
Wayne
You can use Find to find the last used row in C:I by searching backwards from row 1. You should also use Option Explicit to pick up typos in variable names (LstRow).
Sub Auto_Fill_Formula()
Sheets("Sheet1").Select
Dim LastRow As Long, r As Range
With Sheets("Sheet1")
Set r = .Range("C:I").Find(What:="*", After:=.Range("C1"), Lookat:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False)
If Not r Is Nothing Then
LastRow = r.Row
.Range("A2:A" & LastRow).Formula = "Formula added here"
End If
End With
End Sub
The code below is meant to run when the Workbook is first opened.
Sub Auto_Open()
Dim LastRow As Integer
LastRow = Sheet6.UsedRange.Rows.Count
ActiveWorkbook.RefreshAll
Sheet6.AutoFill Destination:=Range("Y2:Y" & LastRow)
End Sub
It automatically runs a Refresh All to update any queries or formula in the WorkBook and then autofills the list of data in column Y of sheet6 to the last row of data that can be found in the WorkSheet.
When I go to run the code I get a 'Compile Error: Method of data member not found' which highlights.
.Autofill
What I don't understand is that this works perfectly well on an identical spreadsheet, not just this one.
I have also tried the following code which doesn't work on this sheet but does on the other.
Sub Auto_Open()
ActiveWorkbook.RefreshAll
Sheet6.AutoFill_ListSource
End Sub
ListSource is the name of the table in column Y that I am trying to autofill.
Change:
Sheet6.AutoFill Destination:=Range("Y2:Y" & LastRow)
to:
Sheet6.Range("Y2").AutoFill Destination:=Sheet6.Range("Y2:Y" & LastRow)
Note: a "safer" way to get the last row, will be using the Find function:
Dim LastCell As Range
Dim LastRow As Long
With Sheet6
Set LastCell = .Cells.Find(What:="*", After:=.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, _
searchorder:=xlByRows, searchdirection:=xlPrevious, MatchCase:=False)
If Not LastCell Is Nothing Then
LastRow = LastCell.Row
Else
MsgBox "Error! worksheet is empty", vbCritical
Exit Sub
End If
End With
Good day, I am newbie in VBA programming. need some help from experts :)
After i enter the date and click the generate button the code will find the date on the excel, but im done with this problem and here are my codes..
Dim Rng As Range
Dim FindDate As Date
FindDate = txtDate.Value
If Trim(FindDate) <> "" Then
With Sheets("Sheet2").Range("B:B")
Set Rng = .Find(What:=FindDate, After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True)
If Not Rng Is Nothing Then
Application.Goto Rng, True
Else
MsgBox "Nothing found"
End If
End With
End If
My next problem is, i need to select the empty cell next to the date.. Here is a screen shot
To answer your specific question, the simplest way would be:
Rng.Offset(, 1).Select
However, you ought to be aware that the Find() function when using dates can be a little unreliable. See this post for more info and links: VBA, goto cell with a certain value (type: date). Your case is particularly exposed to risk as the date is entered via a TextBox.
I have to say your code looks awfully similar to the OP's of that post. You really ought to credit code sources if you didn't write it yourself.
If I were you, I'd convert your textbox value to a Long and then search the cell values (using the .Value2 property which provides date values as Longs) for the matching Long. Code isn't much longer and could look like this:
Dim src As Range
Dim findDate As Date
Dim findVal As Long
Dim cell As Range
'Define the source data range
With Sheet2
Set src = .Range(.Cells(1, "B"), .Cells(.Rows.Count, "B").End(xlUp))
End With
'Acquire search date and convert to long
findDate = CDate(UserForm1.txtDate.Value)
findVal = CLng(findDate)
'Search for date
For Each cell In src.Cells
If cell.Value2 = findVal Then
Application.Goto cell, True
'Select the next cell to the right
cell.Offset(, 1).Select
End If
Next
you could
use a Function to try returning the wanted range
Function SetRange(FindDate As Date) As Range
If Trim(FindDate) <> "" And IsDate(FindDate) Then
With Sheets("Sheet2") '<--| reference wanted sheet
With .Range("B1", .cells(.Rows.Count, 2).End(xlUp)) '<--| reference its column "B" range from row 1 down to last not empty row
On Error Resume Next '<--| if subsequent 'Find()' avoid possible subsequent statement error to stop the Function
Set SetRange = .Find(What:=FindDate, After:=.cells(.cells.Count), LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True).Offset(, 1) '<--| try finding the passed 'FindDate' in referenced range and offset 1 column to the right
End With
End With
End If
End Function
and have your "Main" sub check it against Nothing before using it:
Option Explicit
Sub Main()
Dim Rng As Range
Set Rng = SetRange(txtDate.Text)
If Not Rng Is Nothing Then Rng.Select
End Sub
I hope you can help. I have a some code below which works fine. What it does is opens up a dialog box allows a user to select an excel file, once this file is selected.
The code looks through the column headings find the Text "CountryCode" then cuts this column puts it into Column F then separates column F into new worksheets based on the country.
This issue I am facing is that sometimes the the column I want to cut contains the text "ClientField10" or "ClientField1"
So what I would like the macro to do is search the column headings for "CountryCode" if this is found fine execute the rest of the code.
If it is NOT found search for "CleintField10" then if found execute and if neither "CountyCode" or "CleintField10" is found search for "CleintField1" then execute the rest of the code
My code is below as always any help is greatly appreciated.
Sub Open_Workbook_Dialog()
Dim my_FileName As Variant
Dim my_Workbook As Workbook
MsgBox "Pick your TOV file" '<--| txt box for prompt to pick a file
my_FileName = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*") '<--| Opens the file window to allow selection
If my_FileName <> False Then
Set my_Workbook = Workbooks.Open(Filename:=my_FileName)
Call Sample(my_Workbook) '<--|Calls the Filter Code and executes
Call Filter(my_Workbook) '<--|Calls the Filter Code and executes
End If
End Sub
Public Sub Sample(my_Workbook As Workbook)
Dim ws As Worksheet
Dim aCell As Range, Rng As Range
Dim col As Long, lRow As Long
Dim colName As String
'~~> Change this to the relevant sheet
Set ws = my_Workbook.Sheets(1)
With ws
Set aCell = .Range("A1:BB50").Find(What:="CountryCode", LookIn:=xlValues, LookAt:=xlWhole, _
MatchCase:=False, SearchFormat:=False)
'~~> If Found
If Not aCell Is Nothing Then
'~~> Cut the entire column
aCell.EntireColumn.Cut
'~~> Insert the column here
Columns("F:F").Insert Shift:=xlToRight
Else
MsgBox "Country Not Found"
End If
End With
End Sub
Public Sub Filter(my_Workbook As Workbook)
Dim rCountry As Range, helpCol As Range
With my_Workbook.Sheets(1) '<--| refer to data worksheet
With .UsedRange
Set helpCol = .Resize(1, 1).Offset(, .Columns.Count) '<--| get a "helper" column just at the right of used range, it'll be used to store unique country names in
End With
With .Range("A1:Q" & .Cells(.Rows.Count, 1).End(xlUp).Row) '<--| refer to its columns "A:Q" from row 1 to last non empty row of column "A"
.Columns(6).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=helpCol, Unique:=True '<-- call AdvancedFilter on 6th column of the referenced range and store its unique values in "helper" column
Set helpCol = Range(helpCol.Offset(1), helpCol.End(xlDown)) '<--| set range with unique names in (skip header row)
For Each rCountry In helpCol '<--| iterate over unique country names range (skip header row)
.AutoFilter 6, rCountry.Value2 '<--| filter data on country field (6th column) with current unique country name
If Application.WorksheetFunction.Subtotal(103, .Cells.Resize(, 1)) > 1 Then '<--| if any cell other than header ones has been filtered...
Worksheets.Add Worksheets(Worksheets.Count) '<--... add new sheet
ActiveSheet.Name = rCountry.Value2 '<--... rename it
.SpecialCells(xlCellTypeVisible).Copy ActiveSheet.Range("A1") 'copy data for country under header
End If
Next
End With
.AutoFilterMode = False '<--| remove autofilter and show all rows back
End With
helpCol.Offset(-1).End(xlDown).Clear '<--| clear helper column (header included)
End Sub
Because I didn't get to test my code before, I made the silly mistake of using "If" instead of an "ElseIf" statements. I tested the below code and now it works.
Sub test()
Dim acell As Range
Dim ws As Worksheet
Set ws = ActiveWorkbook.Sheets(1) 'define ws
Set acell = ws.Range("A1:BB50").Find(What:="CountryCode", LookIn:=xlValues, LookAt:=xlWhole, _
MatchCase:=False, SearchFormat:=False) 'define acell as location of "countrycode"
If Not acell Is Nothing Then 'if address is found do the cut & insert of that column
acell.EntireColumn.Cut
Columns("F:F").Insert Shift:=xlToRight
ElseIf acell Is Nothing Then 'if address is not found redefine acell to look for "clientfield10"
Set acell = ws.Range("A1:BB50").Find(What:="ClientField10", LookIn:=xlValues, LookAt:=xlWhole, _
MatchCase:=False, SearchFormat:=False)
If Not acell Is Nothing Then 'if address is found do the cut & insert
acell.EntireColumn.Cut
Columns("F:F").Insert Shift:=xlToRight
ElseIf acell Is Nothing Then 'If not found redefine acell again to look for "ClientField1"
Set acell = ws.Range("A1:BB50").Find(What:="ClientField1", LookIn:=xlValues, LookAt:=xlWhole, _
MatchCase:=False, SearchFormat:=False)
If Not acell Is Nothing Then 'If found do cut and insert
acell.EntireColumn.Cut
Columns("F:F").Insert Shift:=xlToRight
Else: MsgBox "Country Not Found" 'If none can be found display msgbox
End If
End If
End If 'close all the If loops
End Sub
I will delete my old answer to make this thread easier to understand
I am fairly new to VBA so a lot of my code is what I have researched on the internet and put together. A bit background to what I am trying to achieve: -
I have two works books which have an identical layout. One work book is my original where the VBA code is held and the other is a type of overlay document. I have a column with a codes in the Overlay and need to search the original work book same column for this code if its found then copy entire row from overlay into the original and deleting the row found in the original, if its not found in the original just to copy row across.
The line of code I am getting the run-time error on is: -
Set rngFound = Workbooks("OverLay").Worksheets("Overlay").Range("G:G").Find(What:=r.Value, LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
Below is an extract of the code I am using.
Dim sht1 As Worksheet 'Current active worksheet (original version)
Dim sht2 As Worksheet 'Worksheet in OverLay
Dim rngFound As Range
Set sht2 = Workbooks("Overlay").Worksheets("Overlay")
With Workbooks("Original").Worksheets("Formatted")
lastRow = .Range("G" & .Rows.Count).End(xlUp).Row
End With
With sht2
For Each Row In .Range("G:G")
Set rngFound = Workbooks("OverLay").Worksheets("Overlay").Range("G:G").Find(What:=r.Value, LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not rngFound Is Nothing Then
rngFound.Copy
Workbooks("Original").Worksheets("Formatted").Range(rngFound).PasteSpecial
End If
Next
End With
I'll start by showing you what's wrong:
Dim sht1 As Worksheet '// <~~ This never gets used?
Dim sht2 As Worksheet 'Worksheet in OverLay
Dim rngFound As Range
Set sht2 = Workbooks("Overlay").Worksheets("Overlay")
With Workbooks("Original").Worksheets("Formatted")
lastRow = .Range("G" & .Rows.Count).End(xlUp).Row
End With
With sht2
For Each Row In .Range("G:G")
'// 'Row' in the above line will be treated as a variant as it hasn't been declared.
'// As such, it will most likely default to a Range object, which means you are
'// actually looping through each cell in that column. The lesson here is "be explicit"
'// and make sure the code is looking at exactly what you want it to look at.
Set rngFound = Workbooks("OverLay").Worksheets("Overlay").Range("G:G").Find(What:=r.Value, LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
'// You've already set this sheet to 'sht2' so just use that instead. Also, as
'// we know - 'r' has not been set and so causes an error.
If Not rngFound Is Nothing Then
rngFound.Copy
Workbooks("Original").Worksheets("Formatted").Range(rngFound).PasteSpecial
'// 'rngFound' is already a range object, no need to wrap it in a Range() method.
End If
Next
End With
This can be re-written as such:
Dim originalWS As Worksheet '// give your variables meaningful names!
Dim overlayWS As Worksheet
Dim rngSearchParam As Range
Dim rngFound As Range
Set originalWS = Workbooks("Original").Sheets("Formatted")
Set overlayWS = Workbooks("Overlay").Sheets("Overlay")
With overlayWS
For Each rngSearchParam In Intersect(.Range("G:G"), .UsedRange)
Set rngFound = .Range("G:G").Find(rngSearchParam.Value, LookIn:=xlValues, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not rngFound Is Nothing Then
originalWS.Range(rngFound.Address).Value = rngFound.Value
End If
Next
End With
Although it seems like your searching a column, for a value defined by a cell in the same column - so not sure what the "end goal" is here. Hopefully it clarifies the issues you've been having though