Below is my code. All of the code works, but I get error 438 object doesn't support this property or method vba in this line. i.offset(-7,-8).paste
Sub insert_6_rows()
Dim rActive As Range
Dim wb As Workbook
Set rActive = ActiveCell
Application.ScreenUpdating = False
Dim f As Range
Set f = Sheets("Format").Range("A1:J6")
Dim FindST As Range
Set FindST = Sheets("Driver").Range("I:I").Find(What:="Subtotal", LookIn:=xlValues)
FindST.Offset(-1, 0).EntireRow.Resize(6).Insert
f.Copy
Dim i As Range
Set i = Sheets("Driver").Range("I:I").Find(What:="Subtotal", LookIn:=xlValues)
i.Offset(-7, -8).Paste
rActive.Select
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Use the Destination argument of a Range.Copy method.
Sub insert_6_rows()
Dim rActive As Range
Dim wb As Workbook
Set rActive = ActiveCell
Application.ScreenUpdating = False
Dim f As Range, FindST As Range, i As Range
Set f = workSheets("Format").Range("A1:J6")
Set FindST = workSheets("Driver").Range("I:I").Find(What:="Subtotal", LookIn:=xlValues)
FindST.Offset(-1, 0).EntireRow.Resize(6).Insert
f.Copy Destination:=workSheets("Driver").cells(FindST.row-1, "A")
rActive.select
Application.ScreenUpdating = True
End Sub
Use meaningful variable names! Everyone would think of i is a simple counter. Eg. better name it FoundCell.
If nothing is found then you cannot .Offset from "nothing", that's why it fails. So you will need to test if something was found.
I suggest:
Dim FoundCell As Range
Set FoundCell = Sheets("Driver").Range("I:I").Find(What:="Subtotal", LookIn:=xlValues)
'check if something was found
If FoundCell is Nothing Then
MsgBox "Subtotal not found in column I"
Exit Sub
End If
'check if found cell.row is at least 7 rows so we can offset -7
If FoundCell.Row <= 7 Then
MsgBox "Cannot offset -7 rows because found cell is less then 7 rows from top"
Exit Sub
End If
SourceRange.Copy
FoundCell.Offset(-7, -8).Paste
Change Paste to PasteSpecial
i.Offset(-7, -8).PasteSpecial
Related
I believe that I have a scope issue because my variable is defined in another module. The error occurs with WholeSheetRange. I tried defining it as a global variable but then get an object not set error 91. I then tried to define a new range locally within my routine and then my autofilter did not work. No records were ever found.
Here is my code:
Sub date_entered_exit(ByVal Cancel As MSForms.ReturnBoolean)
datevar = inv_list.date_entered
Dim Rng As Range
'Dim date_entered As Date
'date_entered = "13/07/2017"
'date_entered = Format(inv_list.date_entered, "mm/dd/yyyy")
If Not IsDate(datevar) Then
MsgBox "Input must be a date in the format: 'mm/dd/yyyy'"
Cancel = True
Exit Sub
End If
Set Rng = Range("A:A").Find(datevar)
Debug.Print datevar
If Rng Is Nothing Then
MsgBox "Input a date within the range"
Else
WholeSheetRange.AutoFilter Field:=1, Criteria1:="=datevar"
End If
End Sub
Here is my code where WholeSheetRange is defined:
'Declariations to select entire worksheet range
Dim sht As Worksheet
Dim BigLastRow, LastRow As Long
Dim LastColumn As Long
Dim StartCell, WholeSheetRange As Range 'WholeSheetRange
Set sht = Worksheets("Unfiltered_Flight_Schedule")
Set StartCell = Range("A2")
'turn on autofilter and clear filter if there is one
If Not ActiveSheet.FilterMode Then
ActiveSheet.Range("A1").AutoFilter
Else
ActiveSheet.ShowAllData
End If
BigLastRow = sht.Cells(sht.Rows.Count, StartCell.Column).End(xlUp).Row
Set WholeSheetRange = Range("A1:M" & BigLastRow)
This code occurs before the date check and is then used in the following way:
If stn_DEN.Value = True Then
WholeSheetRange.AutoFilter Field:=2, Criteria1:="=DEN"
ElseIf stn_SFO.Value = True Then
WholeSheetRange.AutoFilter Field:=2, Criteria1:="=SFO"
End If
I need to activate a specific worksheet. The code is meant to create worksheets with a specif name. I need to paste something from a another worksheet into all these newly created worksheets. The code that I'm using is below. But I'm having a hard time activating the newly created worksheet to paste what I want.
Sub octo()
'Dim ws As Worksheet
Dim Ki As Range
Dim ListSh As Range
Workbooks.Open ("C:\Users\Dash\Dropbox\Randika\Misc\Emmash timesheets\timesheet.xlsx")
With Worksheets("PPE 05-17-15")
Set ListSh = .Range("B4:B" & .Cells(.Rows.Count, "B").End(xlUp).Row)
End With
On Error Resume Next
For Each Ki In ListSh
If Len(Trim(Ki.Value)) > 0 Then
If Len(Worksheets(Ki.Value).Name) = 0 Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = Ki.Value
'open template
Workbooks.Open ("C:\Users\Dash\Dropbox\Randika\Misc\Emmash timesheets\octo_template.xls")
Range("A1:L31").Select
Selection.Copy
Worksheets(Ki.Value).Activate
If ThisWorkbook.Saved = False Then
ThisWorkbook.Save
End If
End If
End If
Next Ki
End Sub
Both Workbooks.Open and Worksheets.Add return references to the opened and added objects, which you can use to directly access and modify them - and in your case, to paste data.
Example:
Dim oSourceSheet As Worksheet
Dim oTargetSheet As Worksheet
Set oSourceSheet = Sheet1 'Set reference to any sheet, Sheet1 in my example
Set oTargetSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
oSourceSheet.Range("A1:L31").Copy
oTargetSheet.Paste
Set oSourceSheet = Nothing
Set oTargetSheet = Nothing
I think that is what you need. As what been mentioned by chris, there is no need Activate or Select. Hope the following code solve your problem.
Option Explicit
Dim MyTemplateWorkbook As Workbook
Dim MyDataWorkbook As Workbook
Dim MyTemplateWorksheet As Worksheet
Dim MyDataWorksheet As Worksheet
Dim MyNewDataWorksheet As Worksheet
Dim CurrentRange As Range
Dim ListRange As Range
Sub AddWSAndGetData()
Set MyTemplateWorkbook = Workbooks.Open("C:\Users\lengkgan\Desktop\Testing\MyTemplate.xlsx")
Set MyTemplateWorksheet = MyTemplateWorkbook.Sheets("Template")
Set MyDataWorkbook = Workbooks.Open("C:\Users\lengkgan\Desktop\Testing\MyData1.xlsx")
Set MyDataWorksheet = MyDataWorkbook.Sheets("PPE 05-17-15")
Set ListRange = MyDataWorksheet.Range("B4:B" & MyDataWorksheet.Cells(Rows.Count, "B").End(xlUp).Row)
Application.ScreenUpdating = False
On Error Resume Next
For Each CurrentRange In ListRange
If Len(Trim(CurrentRange.Value)) > 0 Then
If Len(MyDataWorksheet(CurrentRange.Value).Name) = 0 Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = CurrentRange.Value
Set MyNewDataWorksheet = MyDataWorkbook.Sheets(ActiveSheet.Name)
MyNewDataWorksheet.Range("A1:L31").Value = MyTemplateWorksheet.Range("A1:L31").Value
If MyDataWorkbook.Saved = False Then
MyDataWorkbook.Save
End If
End If
End If
Next CurrentRange
MyTemplateWorkbook.Close (False) 'Close the template without saving
End Sub
I have one workbook with many order numbers in many different columns(20+). Each Column has a different Header(column name) that can be found in the first row.
On a different sheet I will have all of the order numbers compiled into column A. In column B I would populate the name of the column (header) for each order number.
The code below would provide me a function to return the sheet name. In line 14 I tried changing w.s. name to header but it would not work.
Option Explicit
Function FindMyOrderNumber(strOrder As String) As String
Dim ws As Worksheet
Dim rng As Range
Application.Volatile
For Each ws In Worksheets
If ws.CodeName <> "Sheet3" Then
Set rng = Nothing
On Error Resume Next
Set rng = ws.Cells.Find(What:=strOrder, LookAt:=xlWhole)
On Error GoTo 0
If Not rng Is Nothing Then
FindMyOrderNumber = ws.Name
Exit For
End If
End If
Next
Set rng = Nothing
Set ws = Nothing
End Function
FindMyOrderNumber = ws.Cells(1, rng.Column)
From your description it sounds like you want to return the same value you're passing into the function...
If you mean you want to return the column letter where the header was found then edit the lines below:
'On Error Resume Next 'don't need this...
Set rng = ws.Rows(1).Find(What:=strOrder, LookAt:=xlWhole)
'On Error GoTo 0
If Not rng Is Nothing Then
FindMyOrderNumber = Replace(rng.Address(False, False),"1","")
Exit For
End If
EDIT: To return the value in the cell below the header:
'On Error Resume Next 'don't need this...
Set rng = ws.Rows(1).Find(What:=strOrder, LookAt:=xlWhole)
'On Error GoTo 0
If Not rng Is Nothing Then
FindMyOrderNumber = rng.Offset(1,0).Value
Exit For
End If
I want to find a smarter way to test if two range objects, in fact, refer to the same range:
Set A = Range("B1:B3,A2:C2")
Set B = Range("B1,A2:C2,B3")
Set C = Range("A2,B1:B3,C2")
Set D = Range("B1,A2,B2,C2,B3")
The function I'm trying to write must return True when comparing any pair of ranges described above, and False when comparing any of those ranges to a range containing cells that are not part of the first range or not containing some cells from the first range.
What algorithm other than going cell by cell and checking that Intersect() is not Nothing is there for this problem?
I wrote this code on another forum some years back as a quick method to add a Subtract Range option, the same approach I used in Fast method for determining unlocked cell range
background
This function accepts two ranges, removes the cells where the two ranges intersect, and then produces a string output containing the address of the reduced range. This is done by:
creating a new one-sheet WorkBook
entering the N/A formula into all the cells on this sheet contained in rng1,
clearing the contents of all cells on this sheet that are contained by rng2,
using SpecialCells to return the remaining N/A formulae which represents the cells in rng1 that are not found in rng2,
If the Boolean variable, bBothRanges, is set to True, then the process is repeated with the cells with the opposite range order,
the code then returns the "reduced" range as a string, then closes the WorkBook.
As an example:
'Return the hidden cell range on the ActiveSheet
Set rngTest1 = ActiveSheet.UsedRange.Cells
Set rngTest2 = ActiveSheet.UsedRange.SpecialCells(xlVisible)
If rngTest1.Cells.Count > rngTest2.Cells.Count Then
strTemp = RemoveIntersect(rngTest1, rngTest2)
MsgBox "Hidden cell range is " & strTemp, vbInformation
Else
MsgBox "No hidden cells", vbInformation
End If
In your case the code runs the bBothRanges option and then checks if the RemoveIntersect returns vbNullStringto see if the ranges are the same.
For very short ranges as you have provided, a simple cell by cell loop would suffice, for larger ranges this shortcut may be useful.
Sub Test()
Dim A As Range, B As Range, C As Range, D As Range
Set A = Range("B1:B3,A2:C2")
Set B = Range("B1,A2:C2,B3")
Set C = Range("A2,B1:B3,C2")
Set D = Range("B1,A2,B2,C2,B3")
MsgBox RemoveIntersect(A, B, True) = vbNullString
End Sub
main
Function RemoveIntersect(ByRef rng1 As Range, ByRef rng2 As Range, Optional bBothRanges As Boolean) As String
Dim wb As Workbook
Dim ws1 As Worksheet
Dim rng3 As Range
Dim lCalc As Long
'disable screenupdating, event code and warning messages.
'set calculation to Manual
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
lCalc = .Calculation
.Calculation = xlCalculationManual
End With
'add a working WorkBook
Set wb = Workbooks.Add(1)
Set ws1 = wb.Sheets(1)
On Error Resume Next
ws1.Range(rng1.Address).Formula = "=NA()"
ws1.Range(rng2.Address).Formula = vbNullString
Set rng3 = ws1.Cells.SpecialCells(xlCellTypeFormulas, 16)
If bBothRanges Then
ws1.UsedRange.Cells.ClearContents
ws1.Range(rng2.Address).Formula = "=NA()"
ws1.Range(rng1.Address).Formula = vbNullString
Set rng3 = Union(rng3, ws1.Cells.SpecialCells(xlCellTypeFormulas, 16))
End If
On Error GoTo 0
If Not rng3 Is Nothing Then RemoveIntersect = rng3.Address(0, 0)
'Close the working file
wb.Close False
'cleanup user interface and settings
'reset calculation
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
lCalc = .Calculation
End With
End Function
You could always do it manually, like this:
Private Function isRangeEquivalent(ByRef range1 As Range, ByRef range2 As Range) As Boolean
isRangeEquivelent = (range1.Cells.Count = range2.Cells.Count)
If isRangeEquivelent Then
Dim addresses As collection
Set addresses = New collection
Dim cell As Range
For Each cell In range1.Cells
Call addresses.Add(cell.Address, cell.Address)
Next cell
For Each cell In range2.Cells
If Not isInCollection(addresses, cell.Address) Then
isRangeEquivelent = False
Exit For
End If
Next cell
End If
End Function
Private Function isInCollection(ByRef collection As collection, ByVal sKey As String)
On Error GoTo Catch
collection.Item sKey
isInCollection = True
Exit Function
Catch:
isInCollection = False
End Function
I am trying to execute a search where it searches through a column for "REQM" (no quotes) and set the range of the found cell to d. Then call another sub function that finds where to enter the data into. My FindEntryArea sub function works fine and my first find works great but when it tries to findnext it is not working properly.
Sub FindLoop()
Dim re as Range
Set re = Sheets(1).Range("T:T")
With re
Set d = .Find("REQM", LookIn:=xlFormulas, LookAt:=xlWhole)
MsgBox (d.Row)
Call FindEntryArea
Do
Set d = .FindNext(d)
MsgBox (d.Row)
Call FindEntryArea
Loop While Not d Is Nothing
End With
End Sub
Trying to figure out the error I used msgbox to print out the row of the range that was being found this worked fine for the first cell but did not work for the findnext. I get object variable or with block variable not set. I am fairly new to VBA and this is my first time using findnext so any guidance would be appreciated. Also re is my range and there are plenty of other cells that should be found within it.
Thanks.
EDIT:
Main code and findloop
Public re As Range
Public d As variant
Sub MainCode()
Dim r as Range
Set re = Worksheets("Summary all PIIDB").Range("T:T")
Set r = Worksheets("Summary all PIIDB")
With r
Call FindLoop
End With
End Sub
Sub FindLoop()
With re
Set d = .Find("REQM", LookIn:=xlFormulas, LookAt:=xlWhole)
MsgBox (d.Row)
'Call FindEntryArea
Set d = .FindNext(d)
MsgBox (d.Row)
'Call FindEntryArea
End With
End Sub
I removed the loop just to get findnext working first and yet I am still struggling.
The issue is that you never set the variable "re" or "c" to anything. You really should declare all of your variables before using them to help reduce bugs. Try something like this:
Sub FindLoop()
Dim prevSheet as Worksheet
Dim rng As Range
Dim fnd As Variant
Dim i As Long
prevSheet = ActiveSheet
Sheets(1).Select
'Column T - UsedRange
Set rng = Sheets(1).Range(Cells(1, 20), Cells(ActiveSheet.UsedRange.Rows.Count, 20))
On Error GoTo Not_Found
i = rng.Find("REQM", LookIn:=xlFormulas, LookAt:=xlWhole).Row
On Error GoTo 0
With rng
Set fnd = .Find("REQM", LookIn:=xlFormulas, LookAt:=xlWhole)
Do
Set fnd = .FindNext(fnd)
Call FindEntryArea
MsgBox (fnd.Row)
Loop While i < fnd.Row
End With
prevSheet .select
Exit Sub
Not_Found:
MsgBox """REQM"" not found."
prevSheet.Select
Exit Sub
End Sub
Edit:
I modified the code you posted and it runs correctly for me.
Option Explicit
Public d As Variant
Public re As Range
Sub MainCode()
Dim r As Range
Set re = Worksheets("Summary all PIIDB").Range("T:T")
Set r = Worksheets("Summary all PIIDB").UsedRange
With r
Call FindLoop
End With
End Sub
Sub FindLoop()
On Error GoTo Not_Found
With re
Set d = .Find("REQM", LookIn:=xlFormulas, LookAt:=xlWhole)
MsgBox (d.row)
'Call FindEntryArea
Set d = .FindNext(d)
MsgBox (d.row)
'Call FindEntryArea
End With
On Error GoTo 0
Exit Sub
Not_Found:
MsgBox ("REQM not found!")
Exit Sub
End Sub