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
Related
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!
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
I am trying to feed Worksheet in Runtime to Paste but get Object Required error.
I have tried playing with passing multiple types but still gives an error.
Please advise, how can I pass this country name in run time value, so code picks that up and copies the template in that worksheet.
Dim helpdesksheet As Worksheet
Dim hdr, cr As Integer
Dim H_lastrow As Long
Dim C_lastrow As Long
Dim cnname As String
Dim PasteStart As Range
Dim Sheet, cnsheet As Worksheet
Dim wb1, wb2 As Workbook
Call Import_Files
H_lastrow = Sheets("HelpDeskFile").Cells(Rows.Count, 1).End(xlUp).Row
C_lastrow = Sheets("Country_Lookup").Cells(Rows.Count, 1).End(xlUp).Row
Set wb1 = ActiveWorkbook
For cr = 2 To 2
cnname = Sheets("Country_Lookup").Cells(cr, 1).Value
If sheetExists(cnname) = True Then
Application.DisplayAlerts = False
wb1.Worksheets(cnname).Delete
Application.DisplayAlerts = True
wb1.Worksheets.Add(After:=Sheets(Worksheets.Count)).Name = cnname
Sheets(cnname).Select
Set PasteStart = [cnname!A1]
With wb1.Sheets("Template").UsedRange
.Copy PasteStart
Set PasteStart = PasteStart.Offset(.Rows.Count)
End With
Else
wb1.Worksheets.Add(After:=Sheets(Worksheets.Count)).Name = cnname
cnsheet = wb1.Worksheets(cnname)
Sheets(cnname).Select
Set PasteStart = [cnname!A1]
With wb1.Sheets("Template").UsedRange
.Copy PasteStart
Set PasteStart = PasteStart.Offset(.Rows.Count)
End With
End If
'For hdr = 7 To H_lastrow
'If helpdesksheet.Cells(hdr, 11).Value = cnname Then
'i'll add code later
'End If
'Next hdr
Next cr
Getting Error: Run Time 424 Object Requried
I am Trying to run this Code, which will copy the Source sheet Row to Destination Sheet last Row, but my this code giving error 400 while compiling,
Advance Thanks for Help
Sub CopyData()
Dim sBook_t As String
Dim sBook_s As String
Dim sSheet_t As String
Dim sSheet_s As String
On Error GoTo Errorcatch
sBook_t = "C:\Users\Unknown\Desktop\Free\Calculators.xlsx"
Workbooks.Open (sBook_t)
sBook_s = "C:\Users\Unknown\Desktop\Free\PRODUCT_35.xlsm"
Workbooks.Open (sBook_s)
sSheet_t = "cstdatalist"
sSheet_s = "cstdata"
Sheets(sSheet_s).Range("A2").Copy Destination:=Sheets(sSheet_t).Range("A2")
End Sub
Have a try on following sub.
Sub CopyData()
Dim wb As Workbook
Dim sht, shtLocal As Worksheet
Dim rngPaste As Range
Dim rngLastData, wbPath As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
wbPath = "D:\dBook.xlsx"
Set wb = Workbooks.Open(wbPath)
Set sht = wb.Sheets(1)
Set shtLocal = ThisWorkbook.Sheets("Sheet1")
Set rngPaste = sht.Cells(Rows.Count, 1).End(xlUp).Offset(1) 'Destination range set after last used cell of column A
rngLastData = shtLocal.Cells(Rows.Count, "A").End(xlUp).Address
shtLocal.Range("A1:" & rngLastData).Copy rngPaste
wb.Save
wb.Close
Set sht = Nothing
Set shtLocal = Nothing
Set rngPaste = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
enter code hereHere is my adjustment of your code. What I did is declared the workbooks and the worksheets separately. This way it is clear which workbook/sheet is the source and which is the destination.
Sub CopyData()
Dim sBook_t As String
Dim sBook_s As String
Dim workbook_t As Workbook
Dim sSheet_t As Worksheet
Dim sSheet_s As Worksheet
Dim sSheet_t As String
Dim sSheet_s As String
On Error GoTo Errorcatch
sBook_t = "C:\Users\Unknown\Desktop\Free\Calculators.xlsx"
set workbook_t = Workbooks.Open (sBook_t)
sBook_s = "C:\Users\Unknown\Desktop\Free\PRODUCT_35.xlsm"
set workbook_s = Workbooks.Open (sBook_s)
set sSheet_t = workbook_t.Sheets("cstdatalist")
set sSheet_s = workbook_s.Sheets("cstdata")
sSheet_s.Range("A2").Copy Destination:=sSheet_t.Range("A2")
End Sub
I'm new to VBA and trying to put together a macro to copy in data from another workbook and then hyperlink values on an existing sheet to the sheets i've copied in based on a string value in a cell. For the most part the script works however i'm getting a type mismatch error. Hoping someone can help identify what i'm doing wrong.
Sub CopyTitleDetailData()
'Copy all sheets from Key New Release Detail sheet, overrides existing sheets, copys in new sheets
Dim wb As Workbook, ws As Worksheet, wbTarget As Workbook, wsTarget As Worksheet
Application.ScreenUpdating = False
Set wb = ActiveWorkbook 'Main workbook
Dim pth As String
pth = wb.Path
Dim titleDetailPth As String
titleDetailPth = Left(pth, InStrRev(pth, "\") - 1)
Dim filePthName As String
filePthName = titleDetailPth & "\Files for Pre-Order Report (Macro & Alteryx)\" & "Key New Release Accounts Details.xlsx"
Set wbTarget = Workbooks.Open(filePthName, UpdateLinks = False, ReadOnly = True)
For Each wsTarget In wbTarget.Worksheets 'A loop for each worksheet in the Key New Release Detail workbook
For Each ws In wb.Worksheets 'A loop for each worksheet in the Pre-Order (i.e. active workbook)
If wsTarget.Name = ws.Name Then 'If the sheet I am importing exists, it will be deleted
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
Next ws
wsTarget.Copy After:=wb.Sheets(wb.Sheets.Count) 'Copies it into the last sheet
wb.Sheets(wsTarget.Name).Visible = 0 'Hides the copied sheets
Next wsTarget
wbTarget.Close SaveChanges:=False
Application.ScreenUpdating = True
'Loops through a specified column and when a specified value is found, puts a hyperlink in the cell below
Const cWsName As String = "Title Detail"
Const cSearch As String = "Title"
Const cRow1 As Integer = 1
Const cRow2 As Integer = 800
Const cCol As String = "D"
Dim oWb As Workbook
Dim oWs As Worksheet
Dim rCell1 As Range
Dim rCell2 As Range
Dim iR As Integer
Dim strText As String
Dim strAddr As String
Set oWb = ActiveWorkbook
Set oWs = oWb.Worksheets(cWsName)
For iR = cRow1 To cRow2
Set rCell1 = oWs.Range(cCol & iR)
Set rCell2 = oWs.Range(cCol & iR + 1)
strText = rCell2.Text 'What's written in the cell.
strAddr = rCell2.Address 'The address e.g. B1, B13 ...
If rCell1 = cSearch Then
If strText <> "" Then
'Anchor is the place where i'm placing the hyperlink.
'SubAddress is where the hyperlink will take you
rCell2.Hyperlinks.Add _
Anchor:=rCell2, _
Address:="", _
SubAddress:="'" & rCell2 & "'!" & "A1", _
TextToDisplay:=strText 'The same text that orginally lived in the cell
Else
'What im doing if the cell is empty (i.e. nothing)
End If
End If
Next
Dim beginRow As Long
Dim endRow As Long
Dim chkCol As Long
Dim rowCnt As Long
Dim rngResult As Range
beginRow = 1
endRow = 800
chkCol = 1
With oWs
.Cells.EntireRow.Hidden = False 'Unhides all rows, remove line if that's not desired
For rowCnt = beginRow To endRow
If .Cells(rowCnt, chkCol) = "X" Then
If rngResult Is Nothing Then
Set rngResult = .Cells(rowCnt, 1)
Else
Set rngResult = Union(rngResult, .Cells(rowCnt, 1))
End If
End If
Next rowCnt
End With
If Not rngResult Is Nothing Then rngResult.EntireRow.Hidden = True
End Sub
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Dim oWs As Workbook
Dim targetString As String, targetSheet As Worksheet
Set oWs = ActiveWorkbook
targetString = Cells(Target.Range.Row, Target.Range.Column).Value
Set targetSheet = oWs.Sheets(targetString)
If targetSheet.Visible = False Then
targetSheet.Visible = True
End If
'End on Title Detail Sheet
targetSheet.Select
End Sub
Per this documentation, you have to provide an Address when adding a hyperlink. you seem to be setting Address = ""
https://learn.microsoft.com/en-us/office/vba/api/excel.hyperlinks.add