I am getting a run time error on the below code , can you please assist.
The part and getting the error on is rngRange.Select. Can you advise in any way in which i can amend the below code? Thank you in advance
Sub NameRangeTop(Optional ByRef rngRange As Range)
If rngRange Is Nothing Then
Set rngRange = Application.Selection
Else
rngRange.Select
End If
Dim ActiveRange As Range
Dim NumRows, NumColumns, iCount As Long
Dim CurSheetName As String
CurSheetName = ActiveSheet.Name
Set ActiveRange = Selection.CurrentRegion
ActiveRange.Select
NumRows = ActiveRange.Rows.Count
NumColumns = ActiveRange.Columns.Count
If NumRows = 1 And NumColumns = 1 Then
MsgBox "No active cells in the surrounding area. Try running the macro from a different location", vbCritical, "Local Range Naming"
Exit Sub
End If
If NumRows = 1 Then
Set ActiveRange = ActiveRange.Resize(2)
NumRows = 2
End If
For iCount = 1 To NumColumns
ActiveRange.Resize(NumRows - 1).Offset(1, 0).Columns(iCount).Name = CurSheetName & "!" & ActiveRange.Rows(1).Columns(iCount).Value
Next
ActiveRange.Resize(NumRows - 1).Offset(1, 0).Select
End Sub
it's because the passed rngRangerange doesn't belong to currently active worksheet
code like this
If rngRange Is Nothing Then
Set rngRange = Application.Selection
Else
rngRange.Parent.Activate
rngRange.Select
End If
Related
I'm new to VBA.
I would like to detect the first and last column containing the value "FMD 1991", because I need to copy paste the value of each cells below cells containing the "FMD 1991 value" in a destination sheet.
Here's what I've done
Private Sub CommandButton1_Click()
Dim FMD91 As String
Dim FMD97 As String
Dim FMD13 As String
Dim IECMIL As String
Dim MIL As String
Dim i As Integer
Dim firstcol
Dim finalcol As Integer
FMD91 = "FMD 1991"
Worksheets("FailureModeDistribution_FMD").Select
firstcol = Find(what:="FMD 1991", lookat:=xlWhole, searchorders:=xlByColumns)
finalcol = Find(what:="FDM 1991", lookat:=xlWhole, searchdirection:=xlPrevious)
For i = 2 To finalcol
If Cells(2, i) = FMD91 Then
Range(Cells(2, i)).Copy
FeuilleDonnees.Select
Range("A2").End(xlToRight).PasteSpecial xlPasteFormulasAndNumberFormats
End If
Next i
End Sub
May someone help me with that please?
Please, test the next code. It assumes that there can be more occurrences of the string to be searched for. If only two, the code can be simplified, replacing the iteration with a single code line:
Private Sub CommandButton1_ClickSSS()
Dim sh As Worksheet, shDest As Worksheet, FMD91 As String, firstRng As Range
Dim lastRng As Range, mtch, prevMtch, i As Long
Set sh = ActiveSheet 'Worksheets("FailureModeDistribution_FMD")
Set shDest = sh.Next 'Use your destination sheet (FeuilleDonnees)
FMD91 = "FMD 1991"
mtch = Application.match(FMD91, sh.rows("1:1"), 0)
If IsError(mtch) Then
MsgBox "No any match for " & FMD91 & " in the first row...": Exit Sub
Else
prevMtch = mtch
End If
Set firstRng = sh.Range(sh.cells(2, mtch), sh.cells(sh.rows.count, mtch).End(xlUp)) 'set the first range to be copyed
For i = mtch To sh.UsedRange.Columns.count 'iterate between the rest of columns (in case of more occurrences):
mtch = Application.match(FMD91, sh.Range(sh.cells(1, prevMtch + 1), sh.cells(1, sh.UsedRange.Columns.count)), 0)
If IsNumeric(mtch) Then 'set all occurences as the last range to be copied
Set lastRng = sh.Range(sh.cells(2, mtch + prevMtch), sh.cells(sh.rows.count, mtch + prevMtch).End(xlUp))
prevMtch = prevMtch + mtch
Else
Exit For 'exit the loop and use the last set lastRng
End If
Next i
If lastRng Is Nothing Then MsgBox "No secong match for " & FMD91 & " could be found in the first row...": Exit Sub
'copying the ranges:
firstRng.Copy: shDest.Range("A2").End(xlToRight).Offset(0, 1).PasteSpecial xlPasteFormulasAndNumberFormats
lastRng.Copy: shDest.Range("A2").End(xlToRight).Offset(0, 1).PasteSpecial xlPasteFormulasAndNumberFormats
End Sub
Please, take care of using your real sheets to set sh and shDest. I used ActiveSheet and ActiveSheet.Next only to test the above code.
If only two occurrences of the string to be searched for, please state it and I will simplify the code. It will work with only two occurrences, too. If only one may exist, it can also be adapted to process only that one.
It will return in the next empty column of shDest.
Im at a loss here, why do i get run-time error 91: "object variable or with block variable not set"
What am i doing wrong here and what's the fix?
Thank you in advance!
Set StartCell = Worksheets("Data").Range("A5")
Set StartSheet = Worksheets("Data")
With Worksheets("Data").Range("A4:BZ4")
Set LastColumn = .Find("Comment", LookIn:=xlValues)
Debug.Print StartCell.Row
Debug.Print StartCell.Column
Set Workrange = Range(StartSheet.Cells(StartCell.Row, StartCell.Column), StartSheet.Cells(5000, LastColumn.Column)) 'This line is the issue
End With
If Not Intersect(Target, Workrange) Is Nothing Then
If Target.Count > 1 Then Exit Sub
StartSheet.Cells(Target.Row, LastColumn.Column + 1).Value = Environ("username")
StartSheet.Cells(Target.Row, LastColumn.Column + 2).Value = Format(Now, "dd/mm/yyyy_hh.mm.ss")
End If
End Sub
Issues in your code
Find might not return a hit, test for that
Find uses the last set values for several parameters. Not specifying them can give unexpected results.
Other improvements
If you are going to exit on Target.Count > 1 then just do it
In a Worrksheet code behind module, use Me to refer to that sheet
Dim your variables
Removed redundant With
Cleaned up cumbersome range reference
Private Sub Worksheet_Change(ByVal Target As Range)
Dim StartCell As Range
Dim LastColumn As Range
Dim Workrange As Range
If Target.Count > 1 Then Exit Sub
Set StartCell = Me.Range("A5")
'Debug.Print StartCell.Row
'Debug.Print StartCell.Column
Set LastColumn = Me.Range("A4:BZ4").Find( _
What:="Comment", _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
MatchCase:=False, _
MatchByte:=TRUE) ' only need MatchByte if you have selected or installed double-byte language support.
If Not LastColumn Is Nothing Then
Set Workrange = Me.Range(StartCell, Me.Cells(5000, LastColumn.Column))
If Not Intersect(Target, Workrange) Is Nothing Then
Me.Cells(Target.Row, LastColumn.Column + 1).Value = Environ("username")
Me.Cells(Target.Row, LastColumn.Column + 2).Value = Format$(Now, "dd/mm/yyyy_hh.mm.ss")
End If
End If
End Sub
I'm setting up a userform to find a company's name. Each company has 10 rows of data. I need the button to select the first row and then stop and only run the findnext if button is clicked again.
Currently my code finds the company's name correctly, but because of the loop it directly select the last row with the company's name. I need it to select the first time the name appears and then findnext only if I click on the button again
Private Sub CommandButton1_Click()
Dim lastrow As Long, i As Long, c As String
Dim mycell As Range
lastrow = Sheets("Rent Roll").Range("A" & Rows.Count).End(xlUp).Row
c = TextBox1.Text
With Sheets("Rent Roll").Range("C5:C" & lastrow)
Set mycell = .Find(what:=c, LookIn:=xlValues)
If Not mycell Is Nothing Then
firstAddress = mycell.Address
Do
mycell.Select
Set mycell = .FindNext(mycell)
Loop While Not mycell Is Nothing And mycell.Address <> firstAddress
Else
MsgBox ("Not Found")
End If
End With
Exit Sub
End Sub
If I enter "Google", it should select the first row and then stop. Then if I click the button again, use findnext and select the next cell with "Google"
You should be able to to something like this:
Private Sub CommandButton1_Click()
Static lastCell As Range '<< static variables preserve values between calls
Static lastTerm As String
Dim ws As Worksheet, rngSrch As Range
Dim lastrow As Long, i As Long, c As String
Dim f As Range, afterCell As Range
Set ws = ThisWorkbook.Worksheets("Rent Roll")
Set rngSrch = ws.Range(ws.Range("C5"), ws.Cells(Rows.Count, "C").End(xlUp))
c = TextBox1.Text
'new search term?
If c <> lastTerm Then
Set lastCell = Nothing
lastTerm = c
End If
If Len(c) = 0 Then Exit Sub '<< nothing to search for
If lastCell Is Nothing Then
Set afterCell = Rng.Cells(Rng.Cells.Count)
Else
Set afterCell = lastCell
End If
Set f = rngSrch.Find(what:=c, after:=afterCell, LookIn:=xlValues)
If f Is Nothing Then
MsgBox ("'" & c & "' not found")
Else
If f.Row < lastCell.Row Then
MsgBox "Already at the last row" '<< do this, or just keep wrapping round?
Else
f.Select
Set lastCell = f
End If
End If
End Sub
Current Code is provided below. The user selects the Range of cells from which unique values needs to be found out. Instead of this, I know the Range of cells which is entire Column B of Sheet Database. I tried switching the code by the code below but it's giving "Run-time error '424': Object Required" where I am trying to count the number of rows with data.
Sheets("Database").Activate
last_row = Cells(Row.Count, "B").End(xlUp).Row <- Error
Set rngTarget = Sheets("Database").Range("B2:B" & last_row)
If rngTarget Is Nothing Then Exit Sub
Current Code:
strPrompt = "Select the Range from which you'd like to extract uniques"
On Error Resume Next
Set rngTarget = Application.InputBox(strPrompt, "Get Range", Type:=8)
On Error GoTo 0
If rngTarget Is Nothing Then Exit Sub
Changed Code: (Doesn't work - Gives Run-Time Error)
Sheets("Database").Activate
last_row = Cells(Row.Count, "B").End(xlUp).Row <- Error
Set rngTarget = Sheets("Database").Range("B2:B" & last_row)
If rngTarget Is Nothing Then Exit Sub
rngTarget function should contain the range of cells from which unique values needs to be found out.
Update 1
Complete Code for reference:
Public Sub WriteUniquesToNewSheet()
Dim wksUniques As Worksheet
Dim rngUniques As Range, rngTarget As Range
Dim strPrompt As String
Dim varUniques As Variant
Dim lngIdx As Long
Dim last_row As Long
Dim colUniques As Collection
Set colUniques = New Collection
'Prompt the user to select a range to unique-ify
'strPrompt = "Select the Range from which you'd like to extract uniques"
'On Error Resume Next
' Set rngTarget = Application.InputBox(strPrompt, "Get Range", Type:=8)
'On Error GoTo 0
'If rngTarget Is Nothing Then Exit Sub '<~ in case the user clicks Cancel
Sheets("Database").Activate
last_row = Cells(Row.Count, 2).End(xlUp).Rows
Set rngTarget = Sheets("Database").Range("B2:B" & last_row)
If rngTarget Is Nothing Then Exit Sub
'Collect the uniques using the function we just wrote
Set colUniques = CollectUniques(rngTarget)
'Load a Variant array with the uniques
'(in preparation for writing them to a new sheet)
ReDim varUniques(colUniques.Count, 1)
For lngIdx = 1 To colUniques.Count
varUniques(lngIdx - 1, 0) = CStr(colUniques(lngIdx))
Next lngIdx
'Create a new worksheet (where we will store our uniques)
Set wksUniques = Worksheets("Lists")
Set rngUniques = wksUniques.Range("A2:A" & colUniques.Count + 1)
rngUniques = varUniques
'Let the user know we're done!
MsgBox "Finished!"
End Sub
To get you started, you have refered to Row instead of a range object representing all Rows. Follow the links to see the difference :)
Next you have used .Activate and therefor not specified what worksheet you working from. A better practice would be to use something like:
With Thisworkbook.Sheets("Database") 'Can even be dereferenced from worksheets collection
last_row = .Cells(.Rows.Count, "B").End(xlUp).Row
Set rngTarget = .Range("B2:B" & last_row) 'Tricky if last_row is 1
If rngTarget Is Nothing Then Exit Sub 'Superfluous and can be deleted
End with
I have a large table filled with data. What I want to do is check wether a set of data already exists within this table. I have inserted the data I am looking for in a separate worksheet. The Range with the table items I am looking for I called "SearchedData" and the Area where I am checking wether it holds the data I am looking for I called "SearchArea".
My code only shows me the data would exist but in the worksheet I am working on it doesn't so there must be something wrong with my code. Any help on this would be very much appreciated!
Sub CheckWetherDataExists()
Dim SearchedData As Variant
Dim SearchArea As Variant
SearchedData = ThisWorkbook.Worksheets("Tabelle2").Range("C5:G8").Value
SearchArea = ThisWorkbook.Worksheets("Tabelle1").Range("A:E").Value
If SearchArea = SearchedData Then
MsgBox ("Searched Data already exists")
Else: MsgBox ("Searched Data is missing")
End If
End Sub
This is a way more complicated to solve.
Imagine Tabelle2 as following:
And Tabelle1 as following:
I suggest to use the Range.Find method to find the first occurenc of the first cells data here this is represented by 11. And then check if the rest of the data is right/below there too. Do this in a loop until all occurences are checked.
So in Tabelle1 the yellow areas will be ckecked but the only full match is at A14:E17 which will be considered as duplicate.
Option Explicit
Public Sub CheckIfDataExists()
Dim wsSearch As Worksheet
Set wsSearch = ThisWorkbook.Worksheets("Tabelle1")
Dim SearchRange As Range
Set SearchRange = wsSearch.Range("A1", wsSearch.Cells(wsSearch.Rows.Count, "A").End(xlUp))
Dim SearchData() As Variant 'data array
SearchData = ThisWorkbook.Worksheets("Tabelle2").Range("C5:G8").Value
Dim FoundData() As Variant
'remember first find to prevent endless loop
Dim FirstFoundAt As Range
Set FirstFoundAt = SearchRange.Find(What:=SearchData(1, 1), After:=SearchRange.Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Not FirstFoundAt Is Nothing Then
Dim FoundAt As Range
Set FoundAt = FirstFoundAt
Do
Set FoundAt = SearchRange.Find(What:=SearchData(1, 1), After:=FoundAt, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Not FoundAt Is Nothing Then
FoundAt.Resize(UBound(SearchData, 1), UBound(SearchData, 2)).Select
FoundData = FoundAt.Resize(UBound(SearchData, 1), UBound(SearchData, 2)).Value
If AreArraysEqual(SearchData, FoundData) Then
MsgBox "data found at " & FoundAt.Resize(UBound(SearchData, 1), UBound(SearchData, 2)).Address
Exit Sub
End If
End If
Loop Until FoundAt Is Nothing Or FirstFoundAt.Row >= FoundAt.Row
End If
MsgBox "data not found"
End Sub
Private Function AreArraysEqual(Arr1 As Variant, Arr2 As Variant) As Boolean
Dim iRow As Long, iCol As Long
'default
AreArraysEqual = True
For iRow = LBound(Arr1, 1) To UBound(Arr1, 1)
For iCol = LBound(Arr1, 2) To UBound(Arr1, 2)
If Arr1(iRow, iCol) <> Arr2(iRow, iCol) Then
AreArraysEqual = False
Exit Function
End If
Next iCol
Next iRow
End Function
I believe this code will do what you want reasonably fast.
Sub CheckWetherDataExists()
Dim SearchedData As Variant
Dim SearchArea As Variant
Dim LookFor() As String
Dim LookIn() As String
Dim R As Long, C As Long
SearchedData = ThisWorkbook.Worksheets("Tabelle2").Range("C5:G8").Value
LookFor = MergedRows(SearchedData)
With ThisWorkbook.Worksheets("Tabelle1")
SearchArea = .Range(.Cells(2, 1), .Cells(.Rows.Count, 5).End(xlUp)).Value
End With
LookIn = MergedRows(SearchArea)
For R = 1 To UBound(LookIn)
If LookIn(R) = LookFor(1) Then
If R < UBound(LookIn) - 2 Then
For C = 2 To UBound(LookFor)
If LookIn(R + C - 1) <> LookFor(C) Then Exit For
Next C
If C > UBound(LookFor) Then
MsgBox "Match found in Row " & R
Exit For
End If
End If
End If
Next R
End Sub
Private Function MergedRows(RngVal As Variant) As String()
Dim Fun() As String
Dim R As Long, C As Long
ReDim Fun(1 To UBound(RngVal))
For R = 1 To UBound(RngVal)
For C = 1 To UBound(RngVal, 2)
Fun(R) = Fun(R) & "," & RngVal(R, C)
Next C
Next R
MergedRows = Fun
End Function
The code creates merged strings of 5 cells of both the SearchedData and the SearchArea data. This job is done by the Function MergedRows. In the process the SearchedData turn into array LookFor(1 To 3) and LookIn(1 To LastRow). Next the first element (representing a row) of LookFor is compared to each element (representing a row) of LookIn. If a match is found the other two rows are also compared. When all three elements (rows) match a message is issued and the search is terminated.