is this possible to create a function that returns temporary sheet?
Let's say I have got Sub as follow
Sub My_Sub()
Dim harm As Worksheet
Set harm = Sheets("my_sheet")
Dim lastRow As Long, arr
lastRow = harm.Range("A" & harm.Rows.Count).End(xlUp).Row
arr = harm.Range("T2:V" & lastRow).Value
MsgBox arr(2,5)+1
End Sub
Right now I'm working on harm = Sheets("my_sheet") and it loads whole sheet. Now I want to select part of that sheet and do the same operations so I wanted to write a function that will create temporary sheet, return it so in My_Sub I would have Set harm = ReturnSheet().
Is it possible? I want to load pseudo sheet from function, so I don't need to change anything in My_Sub (I mean those Ranges with column letter indexes).
Function ReturnSheet() As Worksheet
Dim Rng As Range
Dim lastRow As Long
Dim lastCol As Long
Set Rng = Selection
lastRow = Selection.Rows.Count
lastCol = Selection.Columns.Count
ReturnSheet.Range("A2").Resize(lastRow, lastCol).Value = Rng
End Function
Right now I'm getting Object variable or with block variable not set at ReturnSheet.Range("A2").Resize(lastRow, lastCol).Value = Rng
Try using the next Function. It returns a range meaning the selected cells without their first row:
Function ReturnRange(Optional boolAllRange As Boolean = False) As Range
Dim rng As Range: Set rng = Selection
If rng.rows.count = 1 Then Exit Function
If boolAllRange Then
Set ReturnRange = rng
Else
Set ReturnRange = rng.Offset(1).Resize(rng.rows.count - 1, rng.Columns.count)
End If
End Function
You can test it using the next Sub:
Sub testReturnRange()
Dim rng As Range
Set rng = ReturnRange 'eliminating the header
If Not rng Is Nothing Then Debug.Print rng.Address
Set rng = ReturnRange(True) 'header inclusive...
If Not rng Is Nothing Then Debug.Print rng.Address
End Sub
Related
I have been trying to create a function which checks that if Col"B" <> Empty then copy the third cell which is under the same row.
I have this Data:
Where from i want to copy the Col"D" highlighted cells and paste them into same row where Col"B" <> empty.
Here is the final result. Your help will be appreciated in this regards.
Option Explicit
Sub CopyPasting()
Dim ws As Worksheet
Dim r As Long
Dim LastRow As Long
Dim n As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
LastRow = .Range("D" & .Rows.Count).End(xlUp).Row
For r = LastRow To 2 Step -2
If .Cells(r, "B") <> "" Then
.Rows(r + "D").Copy
.Rows(r + "D").PasteSpecial
n = n + 1
End If
Next
End With
End Sub
Please, try the next code:
Sub testRetOffset3()
Dim sh As Worksheet, lastR As Long, rngV As Range, rngFin As Range, c As Range
Set sh = ActiveSheet 'use here the sheet you need
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row 'last sheet row
On Error Resume Next 'if not empty cells in column, it will not return the range and raise an error
Set rngV = sh.Range("B2:B" & lastR).SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If rngV Is Nothing Then Exit Sub 'stop the code if run on a wrong sheet, without empty cells in column B:B
For Each c In rngV.cells 'iterate between the discontinuous range cells
If rngFin Is Nothing Then 'if the final range is not set (first time)
Set rngFin = c.Offset(3, 2) 'set the range = the Offset necessary cell
Else
Set rngFin = Union(rngFin, c.Offset(3, 2)) 'make a Union between existing range and the Offset necessary cell
End If
Next
If Not rngFin Is Nothing Then 'copy both ranges in consecutive columns
rngV.Copy sh.Range("F2")
rngFin.Copy sh.Range("G2")
End If
End Sub
It will return in columns F:G, starting from the second row. It is easy to modify the range where to return...
You can even clear the existing processed columns and return in B:C, or in another sheet.
Edited:
In order to solve the last request, please use the next code:
Sub testRetOffsetMoreRows()
Dim sh As Worksheet, lastR As Long, rngV As Range, rngFin As Range, A As Range
Set sh = ActiveSheet
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row
On Error Resume Next
Set rngV = sh.Range("A2:D" & lastR).SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If rngV Is Nothing Then Exit Sub
For Each A In rngV.Areas 'iterate between the range areas
If rngFin Is Nothing Then
Set rngFin = A.cells(1,2).Offset(3, 3) 'use the second cell of the area
Else
Set rngFin = Union(rngFin, A.cells(1,2).Offset(3, 3))
End If
Next
If Not rngFin Is Nothing Then
rngV.Copy sh.Range("H2")
rngFin.Copy sh.Range("L2")
End If
End Sub
But take care to have continuous ranges when have a value in column B:B. Otherwise, the code may fail... The areas property will return differently.
I wasn't sure where you wanted the output, this will put it into a sheet called "Sheet2". (You'll have to make that before running the code it won't create it for you.)
Dim i As Long
Dim j As Long
Dim lr As Long
Dim srcWS As Worksheet
Dim destWS As Worksheet
Set srcWS = ThisWorkbook.Sheets("Sheet1")
Set destWS = ThisWorkbook.Sheets("Sheet2")
With srcWS
lr = .Cells(.Rows.Count, 4).End(xlUp).Row
j = 2
For i = 2 To lr
If .Cells(i, 2).Value <> "" Then
destWS.Cells(j, 1).Value = .Cells(i, 2).Value
destWS.Cells(j, 2).Value = .Cells(i, 4).Offset(2, 0).Value
j = j + 1
End If
Next i
End With
If you need the colors copied over as well then use this:
.Cells(i, 4).Offset(2, 0).Copy
destWS.Cells(j, 2).PasteSpecial xlPasteAll
instead of:
destWS.Cells(j, 2).Value = .Cells(i, 4).Offset(2, 0).Value
i just get one names range with this code, what's my fault?
any help, my language is so bad, sorry!
Sub Create_Names()
Worksheets("DATA").Activate
Dim rng As Range
With ActiveSheet
Set rng = Range("J2:J10, J47:S67")
End With
rng.Select
With Selection
'Set rng = Selection
Dim i As Integer
Dim n As Long
Dim new_range As Range
Dim col_num As Integer
Dim first_Row As Long
Dim last_row As Long
For i = 1 To rng.Columns.Count
For n = rng.Rows.Count To 1 Step -1
col_num = rng.Columns(i).Column
first_Row = rng.Rows(1).Row
last_row = rng.Rows(n).Row
If Cells(last_row, col_num).Value <> "" Then
Set new_range = Range(Cells(first_Row, col_num), Cells(last_row, col_num))
new_range.CreateNames Top:=True
Exit For
End If
Next n
Next i
End With
End Sub
i have a big data, and i want to create names range once to make it simple.. help me please..
i change my code and its work like i want..
for each rng in Application.Selection.Areas
'i run the code here
next rng
IS THERE LIMIT FOR CREATENAMES?
I GET ERROR WHEN I PUT
Set rng = Range("J2:J10, J47:S67,V47:BI77,BL1:BL21,CB35:CU64,CB120:FW170,CX20:MM35,CX51:EU61")
My data
my name range
I am trying to add data to a Listbox on a Userform, based on the value of the the Cell in column C of the range that is searched. If the cell in column C contains a certain string I would like it to be added to the Listbox.
The below code is as far as I have got but it is returning an empty Listbox with no error.
Private Sub OptionButton12_Click()
Dim I As Integer
Dim lastRow As Integer
Dim searchString As String
searchString = "LISTBOXENTRY"
With ThisWorkbook.Sheets("Sheet1")
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Plybooks.ListBox1.Clear
For I = 1 To lastRow
If Cells(I, 3).Value = searchString Then
Plybooks.ListBox1.AddItem Range("A" & I)
End If
Next I
End Sub
Try using the script below and please let me know if it works!
based on your script above, I assumed some of the dataframe dimensions. please let me know if it is not correct so I can tweak it.
I assumed you are working on first sheet (sheets(1)), and col C is the column you are using for the value check against the "searchString" variable. (if true, append the value in listbox1)
Thanks
Private Sub OptionButton12_Click()
Dim lastRow As Integer
Dim searchString As String
Dim wb As Workbook
Dim sRng As Range
Dim cel As Range
'assign current wb into wb workbook object
Set wb = ThisWorkbook
'assign str you want to search into variable
searchString = "LISTBOXENTRY"
'find last row number in colC (3) using crow function. (assuming you want to do a check on every cell listed in column C)
lastRow = crow(1, 3)
plybooks.listbox1.Clear
'assign range object using dataframe dimensions based on row 1 col C (lbound), to lastrow col3 (ubound)
With wb.Sheets(1)
Set sRng = .Range(.Cells(1, 3), .Cells(trow, 3))
End With
'loops through each cel
For Each cel In sRng
If cel.Value = searchString Then
'adds item into listbox1 if conditional statement is True
plybooks.listbox1.AddItem Item:=cel.Value
Else
End If
Next cel
End Sub
Private Function crow(s As Variant, c As Integer)
crow = Sheets(s).Cells(Rows.Count, c).End(xlUp).Row
End Function
Added cell values in ranges over multiple sheets if cell contains certain value, using the following:
Public Sub PlybookListbox()
'Clear fields before start
Plybooks.ListBox1.MultiSelect = 0
Plybooks.ListBox1.Clear
Plybooks.ListBox1.Value = ""
Plybooks.ListBox1.MultiSelect = 2
Dim AllAreas(2) As Range, Idx As Integer, MyCell As Range, TargetRange As Range
Dim lastrowFrontWing As Long
Dim lastrowNose As Long
Dim lastrowBargeboard As Long
lastrowFrontWing = Worksheets("Front Wing").Cells(Rows.Count, 2).End(xlUp).Row
lastrowNose = Worksheets("Nose").Cells(Rows.Count, 2).End(xlUp).Row
lastrowBargeboard = Worksheets("Bargeboard & SPV").Cells(Rows.Count, 2).End(xlUp).Row
Set AllAreas(0) = Worksheets("Front Wing").Range("c6:c" & lastrowFrontWing)
Set AllAreas(1) = Worksheets("Nose").Range("c6:c" & lastrowNose)
Set AllAreas(2) = Worksheets("Bargeboard & SPV").Range("c6:c" & lastrowBargeboard)
Plybooks.ListBox1.Clear
For Idx = 0 To 2
For Each MyCell In AllAreas(Idx).Cells
If InStr(1, MyCell.Value, "(FS)") > 0 Then
Plybooks.ListBox1.AddItem MyCell.Value
End If
Next MyCell
Next Idx
End Sub
I have this function below which does the following:
Takes two parameters (Header Name, Function Needed).
The Header Name parameter is used to find the heading and subsequently to identify the range of that column up until the last row.
The Function Needed parameter is used to switch in the select statement for any additional steps needed.
At the end of most of the statements, I do a Range.Select then I exit my function with a selected range.
Here is the code:
Function find_Header(header As String, fType As String)
Dim aCell As Range, rng As Range
Dim col As Long, lRow As Long
Dim colName As String
With ActiveSheet
Set aCell = .Range("B2:J2").Find(What:=header, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
'If Found
If Not aCell Is Nothing Then
col = aCell.Column
colName = Split(.Cells(, col).Address, "$")(1)
lRow = Range(colName & .Rows.count).End(xlUp).Row + 1
Set myCol = Range(colName & "2")
Select Case fType
Case "Copy"
'This is your range
Set rng = Range(myCol.Address & ":" & colName & lRow).Offset(1, 0)
rng.Select
End Select
'If not found
Else
MsgBox "Column Not Found"
End If
End With
End Function
As I am trying to clean up my code, I have come across a section where I have specifically hard coded ranges and I am trying to make use of my function instead, however, I am now at a point where I am unable to make use of this function correctly as I cannot "pass" the range back to the sub and I cannot seem to make the selection the range object needed for the sub.
Here is what is in the sub:
Sub Copy_Failed()
Dim xRg As Range, xCell As Range
Dim i As Long, J As Long, count As Long
Dim fType As String, colName As String
Dim y As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
myarray = Array("Defect", "System", "Script")
myEnv = Array("SIT", "UAT")
myDefects = Array("New", "Existing")
i = Worksheets("Run Results").UsedRange.Rows.count
J = Worksheets("Failed").UsedRange.Rows.count
Set y = Workbooks("Template.xlsm")
Set ws1 = y.Sheets("Failed")
Set ws2 = y.Sheets("Run Results")
count = 3
If J = 1 Then
If Application.WorksheetFunction.CountA(ws1.UsedRange) = 0 Then J = 0
End If
ws2.Activate
fType = "Copy"
colName = "Status"
Call find_Header(colName, fType)
End Sub
Before I used the function, the code looked like this:
lngLastRow = Cells(Rows.count, "B").End(xlUp).Row
Set xRg = ws2.Range("E3:E" & lngLastRow & i)
Now these 2 lines are performed in the function, so I don't need it in the sub. I have tried the following:
Set rngMyRange = Selection
Set rngMyRange = ActiveSheet.Range(Selection.Address)
Set xRg = ws2.Range(rngMyRange & i)
But I get the error:
Type mismatch
So I am thinking this:
Select the range in the function then use it in the sub - but how?
Figure out how to pass the actual range object from my function to the sub
Although the second option would require some extra changes in my code, I would think this is the better option to go with.
Ok, so here is an illustration just so you can see what I mean. If you put "one" somewhere in B2:J2 it will select the range. I am only using Select here so that you can see the range it identifies. (Disclaimer: I don't fully understand what you are doing, and not sure you need all this code to achieve what you want.)
The Function now returns a range variable, and is assigned to r. Run the procedure x.
Sub x()
Dim r As Range
Set r = Range("a1", find_Header("one", "Copy"))
r.Select
End Sub
Function find_Header(header As String, fType As String) As Range
Dim aCell As Range, rng As Range
Dim col As Long, lRow As Long
Dim colName As String
With ActiveSheet
Set aCell = .Range("B2:J2").Find(What:=header, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
'If Found
If Not aCell Is Nothing Then
col = aCell.Column
colName = Split(.Cells(, col).Address, "$")(1)
lRow = Range(colName & .Rows.Count).End(xlUp).Row + 1
Set myCol = Range(colName & "2")
Select Case fType
Case "Copy"
'This is your range
Set find_Header = Range(myCol.Address & ":" & colName & lRow).Offset(1, 0)
End Select
'If not found
Else
Set find_Header = Nothing
End If
End With
End Function
I have a code that finds and replaces values in one sheet from a list in another sheet. However, I need this code to also highlight the cell, or flag it in some way so that it can be reviewed manually later. Any suggestions?
Here is the code:
Sub ReplaceValues()
Dim FandR As Worksheet
Dim PDH As Worksheet
Dim rng As Range, rngR As Range
Dim i As Long
Dim rngReplacement
Dim c As Range
Dim curVal As String
Set FandR = Sheets("Find and Replace")
Set PDH = ThisWorkbook.Sheets("Paste Data here")
i = PDH.Rows.Count
With PDH
Set rng = .Range("E1", .Range("E" & i).End(xlUp))
End With
With FandR
Set rngR = FandR.Range("H")
End With
For Each c In rngR
curVal = c.Value
c.Interior.Color = vbYellow
With rng
.Replace curVal, c.Offset(0, 1).Value, xlWhole, , True
End With
Next
End Sub