I'm facing a run-time error '424' on the 'For Each Cell In rg' line. Could anyone help me with this please?
Sub extract()
Dim i As Integer
Dim OpenBook As Workbook
Dim FileLocation As String
Dim rg, Cell As Range
FileLocation = "C:\\xxxxx"
Set OpenBook = Application.Workbooks.Open(FileLocation)
Set rg = OpenBook.Sheet2.Range("B1", Sheet2.Range("B1").End(xlDown)).Cell
i = 0
For Each Cell In rg
If Sheet1.Range("G2").Value = Cell Then
i = i + 1
Sheet1.Range("G7").Offset(i, 0).Value = Cell.Offset(0, 1).Value
End If
Next Cell
End Sub
Related
i have a code that loops through a range of cells and for each name in that range it will add a new sheet and name the new sheet after whatever is in the cell. the line of code "ws.Name = Employee_name" is giving me a 1004 runtime error "Application-Defined or Object-Defined error" it is only giving this error the second time through the look it is able to rename the sheet for the first loop. any ideas on how to prevent this?
Option Explicit
Sub read_WFH_dockets()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim WB As Workbook
Dim ws As Worksheet
Dim Employee_name As String
Set WB = ActiveWorkbook
Dim Rng_Employees As Range
Dim EmployeeFAB
Dim numrows As Long
Dim Fab As String
numrows = Range("A100000").End(xlUp).Row
Set Rng_Employees = Range("B1:B" & numrows)
For Each EmployeeFAB In Rng_Employees.Cells
Employee_name = Range("A" & EmployeeFAB.Row)
Fab = EmployeeFAB.Value
Set ws = WB.Sheets.Add
ws.Name = Employee_name
Set ws = Nothing
Employee_name = ""
Fab = ""
Next
End Sub
I have a macro in a summary workbook that opens a series of source workbooks and then manually calculates my summary workbook. Each cell calls a function to calculate it's summary value (code below). This works fine. However, when I run this it gives me a #NAME! error in any cells that reference named ranges in the source files directly. Why?
This is my code:
Sub UpdateLinks_Click1()
Dim ws As Worksheet
Dim vbasheet As Worksheet
Dim fileInputTable As ListObject
Dim i As Long
Dim filePath As String
Dim openWorkbook As Workbook
Dim tableRow As Range
Dim tableCol As Long
Dim currTableRow As Range
'Dim openWkbs() As Workbook
Application.ScreenUpdating = False
Application.EnableEvents = False
'Application.DisplayAlerts = False
Set vbasheet = ThisWorkbook.Worksheets("VBAData")
Set ws = ThisWorkbook.Worksheets("Score Card")
Set fileInputTable = vbasheet.ListObjects("MetricsFileLocations")
vbaDataArray = fileInputTable.DataBodyRange
ReDim openWkbs(UBound(vbaDataArray))
Application.Calculation = xlCalculationManual
For i = 1 To UBound(vbaDataArray)
Set openWkbs(i) = Workbooks.Open(vbaDataArray(i, 2))
ThisWorkbook.Activate
Next i
ThisWorkbook.Application.Calculate
For i = 1 To UBound(vbaDataArray)
openWkbs(i).Close
Next i
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub
The function called from each cell:
Public Function NewValueFunction(refCell As Range) As Variant
Dim cellCalc As Variant
Dim activeCellVal As Variant
Dim activeWS As Variant
Dim i As Long
Dim activeCell As String
activeCell = refCell.Address
activeWS = refCell.Worksheet.Name
cellCalc = ""
'loop through wbks
For i = 1 To UBound(openWkbs)
With openWkbs(i)
'if value of currwb.currentsheetname.currentcell is "" then ignore it
activeCellVal = .Worksheets(activeWS).Range(activeCell).Value
If Not (activeCellVal = "") And Not (IsError(activeCellVal)) Then
If cellCalc = "" Then
cellCalc = activeCellVal
Else
cellCalc = cellCalc + activeCellVal
End If
End If
End With
Next i
NewValueFunction = cellCalc
End Function
The syntax of the cells that are getting the #NAME! error is the following:
='\\stupid long directory name\[FileName.xlsm]Utilization'!Curr_DataCol_1
I tried manually recalculating the Utilization sheet (the one that contains the errors) after running the macro and closing all the files and that didn't do anything.
ThisWorkbook.Worksheets("Utilization").Calculate
I'm baffled. Please advise.
Thanks!
In VBA I am trying to store a named range into a variable then pass it to a function but I get an error "Object doesn't support this property or method"
Function BOM(val, rng)
Dim CR_Path As String
Application.ScreenUpdating = False
CR_Path = ThisWorkbook.Sheets("Request").Cells(val, 1).Value 'Copy that path from a cell
Set mybook = Workbooks.Open(CR_Path)
mybook.Sheets("BOM").Range("A4:G28").Value = ThisWorkbook.Sheets("BOM").Range("rng").Value
mybook.Close SaveChanges:=True
Application.ScreenUpdating = True
End Function
Sub test()
Dim rng As Variant
Dim val as Integer
rng = ThisWorkbook.Sheets("BOM").Range("myTable").RefersToRange.Value
val = 2
Call BOM(3, rng)
End Sub
RefersToRange is a property of a Name object, not a Range.
Change
ThisWorkbook.Sheets("BOM").Range("myTable").RefersToRange.Value
To
ThisWorkbook.Sheets("BOM").Range("myTable").Value
Or
ThisWorkbook.Names("myTable").RefersToRange.Value
Other than refering to a Named range, there are more issues in your code too
Your code, refactored
'Your are not returning anything, so use a Sub
'Define your parameter types
Sub BOM(PathRow As Long, rng As Range)
Dim CR_Path As String
Application.ScreenUpdating = False
CR_Path = ThisWorkbook.Sheets("Request").Cells(PathRow, 1).Value 'Copy that path from a cell
Set mybook = Workbooks.Open(CR_Path)
' Use the range variable Values property
mybook.Sheets("BOM").Range("A4:G28").Value = rng.Value
mybook.Close SaveChanges:=True
Application.ScreenUpdating = True
End Sub
Sub test()
Dim rng As Range
Dim PathRow As Long ' use meaningful names for variables
Set rng = ThisWorkbook.Names("myTable").RefersToRange
PathRow = 2
' use the variable you defined
BOM PathRow, rng
End Sub
I am pretty new to VBA and am having an issue with my code. I have different hotel names from cell B4 to B27. My goal is to create new worksheets and name each one with the hotel names (going down the list). I tried running the sub procedure below but I am getting an error. The error says:
"Run-time error '1004': Application-defined or object-defined error"
It refers to the line below my comment. Any thoughts on why this is occurring and how I can fix this?
Sub sheetnamefromlist()
Dim count, i As Integer
count = WorksheetFunction.CountA(Range("B4", Range("B4").End(xlDown)))
i = 4
Do While i <= count
' next line errors
Sheets.Add(after:=Sheets(Sheets.count)).Name = Sheets("LocalList").Cells(i, 2).Text
i = i + 1
Loop
Sheets("LocalList").Activate
End Sub
Here is something that I quickly wrote
Few things
Do not find last row like that. You may want to see THIS
Do not use .Text to read the value of the cell. You may want to see What is the difference between .text, .value, and .value2?
Check if the sheet exists before trying to create one else you will get an error.
Is this what you are trying?
Option Explicit
Sub sheetnamefromlist()
Dim ws As Worksheet, wsNew As Worksheet
Dim lRow As Long, i As Long
Dim NewSheetName As String
'~~> Set this to the relevant worksheet
'~~> which has the range
Set ws = ThisWorkbook.Sheets("LocalList")
With ws
'~~> Find last row
lRow = .Range("B" & .Rows.Count).End(xlUp).Row
'~~> Loop through the range
For i = 4 To lRow
NewSheetName = .Cells(i, 2).Value2
'~~> Check if there is already a worksheet with that name
If Not SheetExists(NewSheetName) Then
'~~> Create the worksheet and name it
With ThisWorkbook
.Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = NewSheetName
End With
End If
Next i
End With
End Sub
'~~> Function to check if the worksheet exists
Private Function SheetExists(shName As String) As Boolean
Dim shNew As Worksheet
On Error Resume Next
Set shNew = ThisWorkbook.Sheets(shName)
On Error GoTo 0
If Not shNew Is Nothing Then SheetExists = True
End Function
My assumptions
All cells have valid values i.e which can be used for sheet names. If not, then you will have to handle that error as well.
Workbook (not worksheet) is unprotected
Try,
Sub test()
Dim vDB As Variant
Dim rngDB As Range
Dim Ws As Worksheet, newWS As Worksheet
Dim i As Integer
Set Ws = Sheets("LocalList")
With Ws
Set rngDB = .Range("b4", .Range("b4").End(xlDown))
End With
vDB = rngDB 'Bring the contents of the range into a 2D array.
For i = 1 To UBound(vDB, 1)
Set newWS = Sheets.Add(after:=Sheets(Sheets.Count))
newWS.Name = vDB(i, 1)
Next i
End Sub
Create Worksheets from List
The following will create (and count) only worksheets with valid names.
When the worksheet is already added and the name is invalid, it will be deleted (poorly handled, but it works.)
It is assumed that the list is contiguous (no empty cells).
The Code
Option Explicit
Sub SheetNameFromList()
Const wsName As String = "LocalList"
Const FirstCell As String = "B4"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim ListCount As Long
ListCount = WorksheetFunction.CountA(ws.Range(FirstCell, _
ws.Range(FirstCell).End(xlDown)))
Dim fRow As Long: fRow = ws.Range(FirstCell).Row
Dim fCol As Long: fCol = ws.Range(FirstCell).Column
Dim i As Long, wsCount As Long
Do While i < ListCount
If addSheetAfterLast(wb, ws.Cells(fRow + i, fCol).Value) = True Then
wsCount = wsCount + 1
End If
i = i + 1
Loop
ws.Activate
MsgBox "Created " & wsCount & " new worksheet(s).", vbInformation
End Sub
Function addSheetAfterLast(WorkbookObject As Workbook, _
SheetName As String) _
As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = WorkbookObject.Worksheets(SheetName)
If Err.Number = 0 Then Exit Function
Err.Clear
WorkbookObject.Sheets.Add After:=WorkbookObject.Sheets(Sheets.count)
If Err.Number <> 0 Then Exit Function
Err.Clear
WorkbookObject.ActiveSheet.Name = SheetName
If Err.Number <> 0 Then
Application.DisplayAlerts = False
WorkbookObject.Sheets(WorkbookObject.Sheets.count).Delete
Application.DisplayAlerts = False
Exit Function
End If
addSheetAfterLast = True
End Function
In the code below what I am trying to achieve is that the code searches for the files that are entered in column range F in the given path which is "D:\Checksheets\". I am still learning the FSO and would greatly appreciate any help.
Sub Test()
Dim FSO As Object
Dim FSO_Folder As Object
Dim FSO_file As Object
Dim path As String
Dim sheetref As String
Dim nextform As String
Dim row As Integer
Dim col As Integer
row = 8
col = 6
sheetref = Sheets("Sheet1").Cells(row, col)
'nextform = sheetref
path = "D:\Checksheets\"
Do Until Sheets("Sheet1").Cells(row, col) = "END"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set FSO_Folder = FSO.GetFolder(path)
For Each FSO_file In FSO_Folder.Files
If FSO_file.Name = sheetref Then
MsgBox "done" & path
Else
End If
row = row + 1
Next
Loop
End Sub
The FSO has a built in FileExists method:
...
Set FSO = CreateObject("Scripting.FileSystemObject")
Dim sht As Worksheet, cell As Range
Set sht = Sheets("Sheet1")
Do
Set cell = sht.Cells(row, col)
If cell.Value = "END" Then Exit Do
If FSO.FileExists(path & cell.Value) Then
MsgBox "done " & cell.Value
End If
row = row + 1
Loop
You can remove the FSO code entirely and replace the FileExists call with the built-in Dir$ function:
If Len(Dir$(path & cell.Value)) Then
Thanks to Alex I was able to get the code working. In case someone has similar issue, below is the code:
Sub test()
Set FSO = CreateObject("Scripting.FileSystemObject")
Dim sht As Worksheet, cell As Range
Dim row As Integer
Dim col As Integer
Dim path As String
path = "D:\Checksheets\"
row = 1
col = 6
Set sht = Sheets("Sheet1")
Do
Set cell = sht.Cells(row, col)
If cell.Value = "END" Then Exit Do
If cell.Value <> "" Then ' checks for any empty cells
FSO.FileExists (path)
MsgBox "file exists"
Else
End If
row = row + 1
Loop
End Sub