K
Karen53
Hi,
I am getting a Range of Object Worksheet failed on the line where I set the
"TaxLineItems" range. The others, "AMLineItemsExterior"and
"AMLIneItemsInterior" set with no problem. Only the Tax named range errors
out. Why?
Sub wkbookCreate()
Dim wbkCopyFrom As Workbook
Dim wbkCopyTo As Workbook
Dim rngCopyFrom As Range
Dim rngCopyTo As Range
Dim FromwbkName As String
Dim FromPath As String
Dim FromwbkPath As Variant
Dim wbkCopyFromName As String 'for opening file
Dim LusedRow As Long
Set wbkCopyTo = ThisWorkbook
FromwbkPath = Application.GetOpenFilename(Filefilter:="Excel Files,*.xls")
If FromwbkPath = False Then
Exit Sub 'user hit cancel
End If
Call GetNamePath(FromwbkName, FromPath, FromwbkPath)
'just the filename
wbkCopyFromName = Mid(FromwbkPath, InStrRev(FromwbkPath, "\") + 1)
On Error Resume Next
Set wbkCopyFrom = Workbooks(wbkCopyFromName)
On Error GoTo 0
If wbkCopyFrom Is Nothing Then
Set wbkCopyFrom = Workbooks.Open(FromwbkPath)
On Error GoTo 0
If wbkCopyFrom Is Nothing Then
MsgBox "Cannot find originating file--in use?"
Exit Sub
Else
Application.ScreenUpdating = False
wbkCopyTo.Activate
wbkCopyTo.Sheets((Replace(Tablespg.Name, "'", "''"))).Unprotect
Password:=([MyPassword])
'Pool lists
'CAM
Set rngCopyFrom = wbkCopyFrom.Sheets(Replace(Tablespg.Name, "'",
"''")).Range("J4:J21")
Set rngCopyTo = wbkCopyTo.Sheets(Replace(Tablespg.Name, "'",
"''")).Range("J4:J21")
rngCopyTo.Value = rngCopyFrom.Value
'Tax
Set rngCopyFrom = wbkCopyFrom.Sheets(Replace(Tablespg.Name, "'",
"''")).Range("M4:M21")
Set rngCopyTo = wbkCopyTo.Sheets(Replace(Tablespg.Name, "'",
"''")).Range("M4:M21")
rngCopyTo.Value = rngCopyFrom.Value
'Line Items
'Exterior
Set rngCopyFrom = wbkCopyFrom.Sheets(Replace(Tablespg.Name, "'",
"''")).Range("U4:X304")
Set rngCopyTo = wbkCopyTo.Sheets(Replace(Tablespg.Name, "'",
"''")).Range("U4:X304")
rngCopyTo.Value = rngCopyFrom.Value
'set the Exterior Line Items Named Range
LusedRow = Tablespg.Cells(Rows.Count, "U").End(xlUp).Row
Tablespg.Range("U4:X" & LusedRow).Name = "CAMLineItemsExterior"
LusedRow = 0
'Interior
Set rngCopyFrom = wbkCopyFrom.Sheets(Replace(Tablespg.Name, "'",
"''")).Range("AA4:AD304")
Set rngCopyTo = wbkCopyTo.Sheets(Replace(Tablespg.Name, "'",
"''")).Range("AA4:AD304")
rngCopyTo.Value = rngCopyFrom.Value
'set the Interior Line Items Named Range
LusedRow = Tablespg.Cells(Rows.Count, "AA").End(xlUp).Row
Tablespg.Range("AA4:AD" & LusedRow).Name = "CAMLineItemsInterior"
LusedRow = 0
'Tax
Set rngCopyFrom = wbkCopyFrom.Sheets(Replace(Tablespg.Name, "'",
"''")).Range("AF4:AI154")
Set rngCopyTo = wbkCopyTo.Sheets(Replace(Tablespg.Name, "'",
"''")).Range("AF4:AI154")
rngCopyTo.Value = rngCopyFrom.Value
'set the Tax Line Items Named Range
LusedRow = Tablespg.Cells(Rows.Count, "AF").End(xlUp).Row
Tablespg.Range("AF:AI" & LusedRow).Name = "TaxLineItems" 'this
is where it errors
LusedRow = 0
wbkCopyTo.Sheets(Replace(Tablespg.Name, "'", "''")).Protect
Password:=([MyPassword])
wbkCopyFrom.Close SaveChanges:=False
wbkCopyTo.SaveAs Filename:=FromPath & FromwbkName & " Final.xls"
Application.ScreenUpdating = True
MsgBox "Workbook Structure has been copied."
End If
End If
End Sub
I am getting a Range of Object Worksheet failed on the line where I set the
"TaxLineItems" range. The others, "AMLineItemsExterior"and
"AMLIneItemsInterior" set with no problem. Only the Tax named range errors
out. Why?
Sub wkbookCreate()
Dim wbkCopyFrom As Workbook
Dim wbkCopyTo As Workbook
Dim rngCopyFrom As Range
Dim rngCopyTo As Range
Dim FromwbkName As String
Dim FromPath As String
Dim FromwbkPath As Variant
Dim wbkCopyFromName As String 'for opening file
Dim LusedRow As Long
Set wbkCopyTo = ThisWorkbook
FromwbkPath = Application.GetOpenFilename(Filefilter:="Excel Files,*.xls")
If FromwbkPath = False Then
Exit Sub 'user hit cancel
End If
Call GetNamePath(FromwbkName, FromPath, FromwbkPath)
'just the filename
wbkCopyFromName = Mid(FromwbkPath, InStrRev(FromwbkPath, "\") + 1)
On Error Resume Next
Set wbkCopyFrom = Workbooks(wbkCopyFromName)
On Error GoTo 0
If wbkCopyFrom Is Nothing Then
Set wbkCopyFrom = Workbooks.Open(FromwbkPath)
On Error GoTo 0
If wbkCopyFrom Is Nothing Then
MsgBox "Cannot find originating file--in use?"
Exit Sub
Else
Application.ScreenUpdating = False
wbkCopyTo.Activate
wbkCopyTo.Sheets((Replace(Tablespg.Name, "'", "''"))).Unprotect
Password:=([MyPassword])
'Pool lists
'CAM
Set rngCopyFrom = wbkCopyFrom.Sheets(Replace(Tablespg.Name, "'",
"''")).Range("J4:J21")
Set rngCopyTo = wbkCopyTo.Sheets(Replace(Tablespg.Name, "'",
"''")).Range("J4:J21")
rngCopyTo.Value = rngCopyFrom.Value
'Tax
Set rngCopyFrom = wbkCopyFrom.Sheets(Replace(Tablespg.Name, "'",
"''")).Range("M4:M21")
Set rngCopyTo = wbkCopyTo.Sheets(Replace(Tablespg.Name, "'",
"''")).Range("M4:M21")
rngCopyTo.Value = rngCopyFrom.Value
'Line Items
'Exterior
Set rngCopyFrom = wbkCopyFrom.Sheets(Replace(Tablespg.Name, "'",
"''")).Range("U4:X304")
Set rngCopyTo = wbkCopyTo.Sheets(Replace(Tablespg.Name, "'",
"''")).Range("U4:X304")
rngCopyTo.Value = rngCopyFrom.Value
'set the Exterior Line Items Named Range
LusedRow = Tablespg.Cells(Rows.Count, "U").End(xlUp).Row
Tablespg.Range("U4:X" & LusedRow).Name = "CAMLineItemsExterior"
LusedRow = 0
'Interior
Set rngCopyFrom = wbkCopyFrom.Sheets(Replace(Tablespg.Name, "'",
"''")).Range("AA4:AD304")
Set rngCopyTo = wbkCopyTo.Sheets(Replace(Tablespg.Name, "'",
"''")).Range("AA4:AD304")
rngCopyTo.Value = rngCopyFrom.Value
'set the Interior Line Items Named Range
LusedRow = Tablespg.Cells(Rows.Count, "AA").End(xlUp).Row
Tablespg.Range("AA4:AD" & LusedRow).Name = "CAMLineItemsInterior"
LusedRow = 0
'Tax
Set rngCopyFrom = wbkCopyFrom.Sheets(Replace(Tablespg.Name, "'",
"''")).Range("AF4:AI154")
Set rngCopyTo = wbkCopyTo.Sheets(Replace(Tablespg.Name, "'",
"''")).Range("AF4:AI154")
rngCopyTo.Value = rngCopyFrom.Value
'set the Tax Line Items Named Range
LusedRow = Tablespg.Cells(Rows.Count, "AF").End(xlUp).Row
Tablespg.Range("AF:AI" & LusedRow).Name = "TaxLineItems" 'this
is where it errors
LusedRow = 0
wbkCopyTo.Sheets(Replace(Tablespg.Name, "'", "''")).Protect
Password:=([MyPassword])
wbkCopyFrom.Close SaveChanges:=False
wbkCopyTo.SaveAs Filename:=FromPath & FromwbkName & " Final.xls"
Application.ScreenUpdating = True
MsgBox "Workbook Structure has been copied."
End If
End If
End Sub