VBA in Excel: Runtime Error 1004 - excel

I am trying to do the following. I have several spreadsheets that are named something like "ITT_198763" where the ITT part stays the same but the number changes. I also have one tab called program where the 6 digit number is imported on row 40 (hence the RngToSearch below). I need the program to 1) find the "ITT" sheet for a certain 6 digit number, 2) identify the corresponding row in the "Program" tab, and copy information from the "ITT" tab to row 41 of the identified column. I will be copying more information from the ITT sheet to the specified column, but for now I am just trying to get it to work once.
From the MsgBox, I know it identifies the correct prjNumber (the 6 digit number), but I get the runtime 1004 error on the line Set RngDest. Any help will be appreciated!
Sub Summary_Table()
Dim wks As Worksheet
Dim RngToSearch As Range, RngDest As Range
Dim foundColumn As Variant
Dim prjNumber
For Each wks In ActiveWorkbook.Worksheets
If ((Left(wks.Name, 3) = "ITT")) Then
prjNumber = Right(wks.Name, 6)
MsgBox (prjNumber)
Set RngToSearch = Sheets("Program").Range("C40:q40")
foundColumn = Sheets("Program").Application.Match(prjNumber, RngToSearch, False)
With Sheets("Program")
Set RngDest = .Range(1, foundColumn) 'Project Name
End With
If Not IsError(foundColumn) Then
wks.Range("E2").Copy RngDest
End If
End If
Next wks
End Sub
I tried the .cell instead with the following code (all else is the same) and now get runtime error 13 on the Set RngDest line:
Set RngToSearch = Sheets("Program").Range("C40:q48")
foundColumn = Sheets("Program").Application.Match(prjNumber, RngToSearch.Rows(1), False)
With Sheets("Program")
Set RngDest = RngToSearch.Cells(1, foundColumn) 'Project Name
End With

Yuo are getting that error because foundColumn has an invalid value. Step through the code and see what is the value of foundColumn
Here is an example which works.
Sub Sample()
Dim RngDest As Range, RngToSearch As Range
foundColumn = 1
Set RngToSearch = Sheets("Program").Range("C40:q40")
Set RngDest = RngToSearch.Cells(1, foundColumn)
Debug.Print RngDest.Address
End Sub
Add MsgBox foundColumn before the line Set RngDest = RngToSearch.Cells(1, foundColumn) and see what value do you get. I guess the line
foundColumn = Sheets("Program").Application.Match(prjNumber, RngToSearch, False)
is not giving you the desired value. Here is the way to reproduce the error.
EDIT (Solution)
You need to handle the situation when no match is found. Try something like this
Sub Sample()
Dim RngDest As Range, RngToSearch As Range
Set RngToSearch = Sheets("Program").Range("C40:q40")
foundcolumn = Sheets("Program").Application.Match(1, RngToSearch, False)
If CVErr(foundcolumn) = CVErr(2042) Then
MsgBox "Match Not Found"
Else
Set RngDest = RngToSearch.Cells(1, foundcolumn)
'
'~~> Rest of the code
'
End If
End Sub

You are looking for the Cells function, which has the prototype .Cells([RowIndex], [ColumnIndex]). The Range function takes either a string with a range name (like "A1", or a named range), or other range references.

I figured it out! Found column was the problem. Combining that with the help from the other commenters, the following works:
Sub Summary_Table()
Dim wks As Worksheet
Dim RngToSearch As Range, RngDest As Range
Dim foundColumn As Variant
Dim prjNumber
For Each wks In ActiveWorkbook.Worksheets
If ((Left(wks.Name, 3) = "ITT")) Then
prjNumber = Right(wks.Name, 6)
MsgBox (prjNumber)
Set RngToSearch = Sheets("Program").Range("a40:q48")
foundColumn = Sheets("Program").Rows(40).Find(what:=prjNumber, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False).Column
MsgBox (foundColumn)
With Sheets("Program")
Set RngDest = RngToSearch.Cells(2, foundColumn) 'Project Name
Debug.Print RngDest.Address
End With
If Not IsError(foundColumn) Then
wks.Range("E3").Copy RngDest
End If
End If
Next wks
End Sub

Related

Search range for all cells with specific text and change the value of all adjacent cell to 0

Looking for help to achieve searching a range of cells E9:E with All cells containing "Accommodation & Transportation" and changing the value of the cells adjacent to them with 0. , I was not able to get anything online with similar topic and I'm not too good with VBA coding, though i am able to understand what the code will provide in results.
I Have a Commandbutton1 with the below code :
Sub CommandButton1_click()
Dim blanks As Excel.Range
Set blanks = Range("F9:F" & Cells(Rows.Count, 5).End(xlUp).Row).SpecialCells(xlCellTypeBlanks)
blanks.Value = blanks.Offset(0, -1).Value
End Sub
Further i have a command button that will select only cells that are not blank. I need the above result because if the below code selects Non Blank cells from Columns E:F it wont be selecting cells adjacent to those containing "Accommodation & Transportation" as they are blank cells and it will return the error "Runtime Error '1004' This action wont work on multiple selections".
The below code acts the same as [Go to Special => Constants]
Sub SelectNonBlankCells()
Dim rng As Range
Dim OutRng As Range
Dim InputRng As Range
Dim xTitle As String
On Error Resume Next
xTitle = Application.ActiveWindow.RangeSelection.Address
Set InputRng = Range("E8:F500")
ActiveWindow.ScrollRow = 1
For Each rng In InputRng
If Not rng.Value = "" Then
If OutRng Is Nothing Then
Set OutRng = rng
Else
Set OutRng = Application.Union(OutRng, rng)
End If
End If
Next
If Not (OutRng Is Nothing) Then
OutRng.Select
End If
End Sub
Maybe you can try another approach, if your goal is to edit cells adjacent to certain cells. The code below is based on an example in the Help file of the Range.Find function:
Sub DoSomething()
Dim sh As Worksheet
Set sh = ActiveSheet
Dim checkRange As Range
Set checkRange = sh.Range("E8:F500") ' your intended range to search
Dim foundRange As Range
Set foundRange = checkRange.Find("Accommodation & Transportation")
Dim firstAddr As String
If Not foundRange Is Nothing Then
firstAddr = foundRange.Address
Do
' use foundRange to access adjacent cells with foundRange.Offset(row, col)
'
'
foundRange.Offset(0, 1) = "all good"
Set foundRange = checkRange.FindNext(foundRange)
Loop While Not foundRange Is Nothing And foundRange.Address <> firstAddr
End If
End Sub
Or even better, you could add some parameters to make it more reusable:
Sub Main()
DoSomething "Accommodation & Transportation", ActiveSheet.Range("E8:F500")
End Sub
Sub DoSomething(ByVal findWhat As String, ByVal searchWhere As Range)
Dim foundRange As Range
Set foundRange = searchWhere.Find(findWhat)
Dim firstAddr As String
If Not foundRange Is Nothing Then
firstAddr = foundRange.Address
Do
' use foundRange to access adjacent cells with foundRange.Offset(row, col)
'
'
foundRange.Offset(0, 1) = "all good"
Set foundRange = searchWhere.FindNext(foundRange)
Loop While Not foundRange Is Nothing And foundRange.Address <> firstAddr
End If
End Sub

How to use cell address as a parameter of Range()?

I have a template file that I will use to populate more files and I need to hide some rows according to what its selected, but at the same time I can't hide other rows. I can do it well if the data stay the same size all the time, but the file will be increasing and decreasing depending on the information.
I have a range of values in Column C. What I tried to do is to look for the cell value that contains "Pack" (It will be same for all files). From that cell that contains "Pack" (let's assume that is at C8 now, but can be in C30 in other file) I need to start looking for values that are not equal to the one that I have from a droplist (rowing) and hide the rows.
Maybe better explained, also I tried to do was to assign a variable that will hold the value of the droplist and just look for values that was not equal and simply hide it. Then do a .Find() to find the "Pack" word. Once it was found, get the cell address. Finally take that address and use it as a parameter in Range() as yo can see in the code that I wrote: For Each cell In Range("packR:C5") and I know that is very wrong because I can't pass that.
Dim cell As Range
Dim pack As Range
rowing = Range("A2").Value
Set pack = Range("C1:C12").Find("Pack")
Set packA = Range(pack.Address)
Set packR = packA
For Each cell In Range("packR:-end point here")
cell.EntireRow.Hidden = False
If Not IsEmpty(cell) Then
If cell.Value <> rowing Then
cell.EntireRow.Hidden = True
End If
End If
Next
I have very little vba background but with research I can understand a few. Basically the goal is to ignore all the rows in top of "Pack" and start looking from "Pack" (That need to have a cell address) to the end of the excel file. The biggest issue is to take that cell address and use it as parameter to the Range ("":"").
I think you're looking for something like this. Note the comment about specifying the other parameters of Range.Find.
Sub Test()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim rowing As Variant
rowing = ws.Range("A2").Value
Dim pack As Range
Set pack = ws.Range("C1:C12").Find("Pack") '<--- you should specify the other parameters of Find
Dim lastCell As Range
Set lastCell = ws.Cells(ws.Rows.Count, "C").End(xlUp)
If Not pack Is Nothing Then '<--- tests to see if pack was found
Dim cell As Range
For Each cell In ws.Range(pack, lastCell)
If Not IsEmpty(cell) Then
cell.EntireRow.Hidden = (cell.Value <> rowing)
End If
Next
End If
End Sub
EDIT:
End(xlUp) will not find the true last row if rows are already hidden. To get around this, here are two options:
Unhide all rows after finding "Pack".
Sub Test()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim rowing As Variant
rowing = ws.Range("A2").Value
Dim pack As Range
Set pack = ws.Range("C1:C12").Find("Pack") '<--- you should specify the other parameters of Find
If Not pack Is Nothing Then '<--- tests to see if pack was found
ws.UsedRange.EntireRow.Hidden = False '<--- unhide all rows so as to find the last cell properly
Dim lastCell As Range
Set lastCell = ws.Cells(ws.Rows.Count, "C").End(xlUp)
Dim cell As Range
For Each cell In ws.Range(pack, lastCell)
If Not IsEmpty(cell) Then
cell.EntireRow.Hidden = (cell.Value <> rowing)
End If
Next
End If
End Sub
Use an alternate way of finding the last cell:
Sub Test()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim rowing As Variant
rowing = ws.Range("A2").Value
Dim pack As Range
Set pack = ws.Range("C1:C12").Find("Pack") '<--- you should specify the other parameters of Find
Dim lastCell As Range
Set lastCell = GetLastCell(ws, 3)
If Not pack Is Nothing Then '<--- tests to see if pack was found
Dim cell As Range
For Each cell In ws.Range(pack, lastCell)
If Not IsEmpty(cell) Then
cell.EntireRow.Hidden = (cell.Value <> rowing)
End If
Next
End If
End Sub
Private Function GetLastCell(ByVal ws As Worksheet, Optional ByVal colNum As Long = 1) As Range
With ws
Dim lastCell As Range
Set lastCell = .Columns(colNum).Find(What:="*", _
After:=.Cells(1, colNum), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If lastCell Is Nothing Then
Set lastCell = .Cells(1, colNum)
End If
End With
Set GetLastCell = lastCell
End Function

Insert new row under a specific text using vba

I am trying to insert new row under a particular text(selected from userform) with the new text but getting an error "Object variable or With block variable not set" in the line "fvalue.Value = Me.txtremark.Value".
Please help me to find where exactly the mistake I did in the Code. I was trying to find many ways but failed.
Excel Table:
Required Output:
Private Sub cmdadd_Click()
Dim fvalue As Range
Dim wks As Worksheet
Set wks = ThisWorkbook.Worksheets("Sheet1")
wks.Activate
Set fvalue = wks.Range("B:B").Find(What:=Me.txtremark.Value, LookIn:=xlFormulas, LookAt:=xlWhole)
fvalue.Value = Me.txtremark.Value
fvalue.Offset(1).EntireRow.Insert Shift:=xlDown
fvalue.Offset(0, 1).Value = Me.txtplace.Value
End Sub
Try:
Option Explicit
Sub test()
Dim Position As Range, rngToSearch As Range
Dim strToFound As String
'Change strToFound value
strToFound = "Test"
With ThisWorkbook.Worksheets("Sheet1")
Set rngToSearch = .Range("B:B")
Set Position = rngToSearch.Find(strToFound, LookIn:=xlValues, Lookat:=xlWhole)
If Not Position Is Nothing Then
Debug.Print Position.Row
.Rows(Position.Row).Offset(1).EntireRow.Insert
End If
End With
End Sub
Try using a separate variable to pass values to the worksheet, or just refer to the textbox.
Additionally, activating (and selecting) is not necessary and will hurt your macro's speed and is prone to errors.
Option Explicit
Private Sub cmdadd_Click()
Dim fvalue As Range
Dim wks As Worksheet
Set wks = ThisWorkbook.Worksheets("Sheet1")
Set fvalue = wks.Range("B:B").Find(What:=Me.txtremark.Value, LookIn:=xlFormulas, LookAt:=xlWhole)
If Not fvalue Is Nothing Then
wks.Rows(fvalue.Row + 1).EntireRow.Insert
wks.Cells(fvalue.Row + 1, fvalue.Column + 1).Value = Me.txtremark.Value
End If
End Sub
I have taken the liberty to check if the value is found in the first place

VBA - how to choose a column containing a specific cell and name it output column?

There is a cell in another worksheet whose value ranges from 1 to 100, I have defined its name as "SpanLength" in the name manager. In the worksheet I am now concerned with, I want to find the cell which contains the same value as "SpanLength", that is, a value from 1 to 100, within the range I have defined as "FindSpanLength". Then I want to call the column that this cell is within "outputcolumn" so that I can use this column further in the script. How can I do this?
The line of code before End Sub causes the error message 'Wrong number of arguments or invalid property assignment'
I am a VBA novice and no doubt my code is fraught with errors, so would appreciate any help I can get. I have already scoured google for answers but haven't found any specific enough for me to understand.
Sub OutputMaximums()
Dim spanlengthcell As Range
Set spanlengthcell = Range("FindSpanLength").Find("SpanLength")
Range("spanlengthcell").Column(1) = outputcolumn
End Sub
New Code, with error message 1004 (Method 'Range' of object '_Worksheet' failed):
Sub OutputMaximums()
Dim spanlengthcell As Range, outputcolumn As Long
Set spanlengthcell = OUTPUT.Range("FindSpanLength").Find(Range("SpanLength").Value)
If Not spanlengthcell Is Nothing Then
outputcolumn = spanlengthcell.Column
End If
End Sub
When you assign a value to a variable, the variable is on the left hand side of the equals sign.
When using Find always check first that your search term is found before trying to access its properties to avoid subsequent errors.
It is also advisable to specify a number of Find parameters as they may have unexpected settings from when last used on a worksheet.
Sub OutputMaximums()
Dim spanlengthcell As Range, outputcolumn As Long
Set spanlengthcell = Range("FindSpanLength").Find(Range("SpanLength").Value)
If Not spanlengthcell Is Nothing Then
outputcolumn = spanlengthcell.Column
End If
End Sub
Option Explicit
Sub test()
Dim rngSearch As Range, rngFound As Range
Dim strSearch As String
Dim ColumnNo As Long
strSearch = "Bingo"
With ThisWorkbook.Worksheets("Sheet1")
Set rngSearch = .UsedRange
Set rngFound = rngSearch.Find(strSearch)
If rngFound Is Nothing Then
MsgBox strSearch & " does not excist in range."
Else
ColumnNo = rngFound.Column
MsgBox "Text appears in column " & ColumnNo & "."
End If
End With
End Sub
Sub ShowNamedRange()
'The named Range "SpanLenght" must be on the Sheet "SheetWithNamedRange"!
Debug.Print Sheet("SheetWithNamedRange").Range("SpanLength").Address
Debug.Print Sheet("SheetWithNamedRange").Range("SpanLength").Column
End Sub
and after reading the question again:
Sub SearchRange()
Dim rngSearch As Range
Dim rngFound As Range
Dim strSearch As String
strSearch = Sheets("SheetWithNamedRange").Range("SpanLength").Value
Set rngSearch = Sheets("SheetWithFINDRange").Range("FindSpanLength")
Set rngFound = rngSearch.Find(strSearch)
If Not (rngFound Is Nothing) Then _
MsgBox "Found in column " & rngFound.Column & _
" on the sheet """ & rngFound.Parent.Name & """!"
End Sub

In range find this and do that

Have a range of cell with column headings as weeks In the range of cells I want to look for a number, say
1 if it finds a 1 then look at a column in said row for a variable, 2 or 4 whatever Now I want to put a triangle (can be copy and paste a cell) in the cell that has the "1" in it then skip over the number of week variable and add another triangle and keep doing this until the end of the range. Then skip down to the next row and do the same, until the end of the range.
Then change to the next page and do the same thing... through the whole workbook.
I think I have it done, don't know if it's the best way.
I get a error 91 at the end of the second loop, the first time the second loop ends it goes through the error code.
The second time the second loop ends it errors.
I don't understand it runs through once, but not twice.
Sub Add_Triangles2()
Dim Rng As Range
Dim OffNumber As Integer
Dim SetRange As Range
Dim OffsetRange As Range
Dim ws As Worksheet
Set SetRange = Sheets("Sheet1").Range("G25") ' Used to stop the second loop in range
Worksheets(1).Activate
Worksheets(1).Range("A1").Select ' Has item to be pasted (a triangle)
Selection.Copy
For Each ws In Worksheets
Worksheets(ws.Name).Activate
With Range("C4:G25")
Set Rng = .Find(1, LookIn:=xlValues)
If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Do
Rng.Activate
ActiveSheet.Paste
Do
OffNumber = Range("A" & ActiveCell.Row)
Set OffsetRange = SetRange.Offset(0, -OffNumber)
If Not ActiveCell.Address < OffsetRange.Address Then
Exit Do
Else
End If
ActiveCell.Offset(, OffNumber).Select
ActiveSheet.Paste
Loop While (ActiveCell.Address <= OffsetRange.Address)
On Error GoTo ErrorLine
Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
End With
ErrorLine:
On Error GoTo 0
Application.EnableEvents = True
Next ws
Application.CutCopyMode = False
End Sub
I was not able to get an Error 91 using the data set I built from your explanation, maybe a screenshot of the layout could help recreate the issue.
However, I would do something like this, it will look at the value of each cell in the range C4:G25, and if it equals 1, it will paste the symbol stored in Cell A1.
Sub Add_Triangles2()
Dim Rng As Range
Dim rngSymbol As Range
Dim intFindNum As Integer
Dim ws As Worksheet
Set rngSymbol = Range("A1") 'Set range variable to hold address of symbol to be pasted
intFindNum = 1 'Used to hold number to find
Worksheets(1).Activate
For Each ws In Worksheets
Worksheets(ws.Name).Activate
For Each Rng In Range("C4:G25")
If Rng.Value = intFindNum Then
rngSymbol.Copy Rng
End If
Next Rng
Next ws
End Sub
I got it....
Sub Add_TriWorking()
Dim Rng As Range
Dim rngSymbol As Range
Dim intFindNum As Integer
Dim ws As Worksheet
Dim OffNumber As Integer
Dim SetRange As Range
Dim OffsetRange As Range
Set SetRange = Sheets("Sheet1").Range("G25") ' Used to stop the second loop in range
Set rngSymbol = Range("A1") 'Set range variable to hold address of symbol to be pasted
intFindNum = 1 'Used to hold number to find
Worksheets(1).Activate
For Each ws In Worksheets
Worksheets(ws.Name).Activate
For Each Rng In Range("C4:G25")
If Rng.Value = intFindNum Then
rngSymbol.Copy Rng
Rng.Activate
ActiveCell.Copy
Do
OffNumber = Range("A" & ActiveCell.Row)
Set OffsetRange = SetRange.Offset(0, -OffNumber)
If Not ActiveCell.Address < OffsetRange.Address Then
Exit Do
Else
End If
ActiveCell.Offset(, OffNumber).Select
ActiveSheet.Paste
Loop While (ActiveCell.Address <= OffsetRange.Address)
On Error GoTo ErrorLine
End If
Next Rng
ErrorLine:
On Error GoTo 0
Application.EnableEvents = True
Next ws
Application.CutCopyMode = False
End Sub

Resources