I want to define a variable range in an Excel macro with VBA. The first cell is always A25, but the last cell is moving depending on the number of data collected. This can be E35, or E58, etc. Any idea how to do this?
There are 2 options:
Option 1: the Range you are looking to define is continuous (see screen-shot below):
the easy approach will do:
Option Explicit
Sub DefRange()
Dim Rng As Range
With Worksheets("Sheet1") '<-- modify "Sheet" to your sheet's name
Set Rng = .Range("A25").CurrentRegion
Debug.Print Rng.Address '<-- for debug: will show A25:E35
End With
End Sub
Option 2: the Range you are looking to define, has an empty line in the middle (screen-shot below):
then, the previous method will result with the wrong range
Option Explicit
Sub DefRange()
Dim Rng As Range
Dim LastRow As Long
Dim LastCol As Long
With Worksheets("Sheet1") '<-- modify "Sheet" to your sheet's name
Set Rng = .Range("A25").CurrentRegion
Debug.Print Rng.Address '<-- for debug: will show A25:E35 ***WRONG***
'Search for any entry, by searching backwards by Rows.
LastRow = .Cells.Find(What:="*", After:=.Range("A25"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'Search for any entry, by searching backwards by Columns.
LastCol = .Cells.Find(What:="*", After:=.Range("A25"), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Set Rng = .Range(.Cells(25, "A"), .Cells(LastRow, LastCol))
Debug.Print Rng.Address '<-- for debug: will show A25:F37 ***CORRECT***
End With
End Sub
You can define a range as its two limit cells. Let's say you are working in the worksheet "ws":
Dim rng As Range
Dim cl1 As Range: Set cl1 = ws.Range("A25")
Dim cl2 As Range
Set cl2 = ws.Range("E35") 'Or something else'
Set rng = ws.Range(cl1, cl2)
Just count the rows in Column E,
Sub Button1_Click()
Dim LstRw As Long
Dim Rng As Range, x
LstRw = Cells(Rows.Count, "E").End(xlUp).Row
x = IIf(LstRw > 25, LstRw, 25)
Set Rng = Range("A25:E" & x)
Rng.Select
End Sub
Related
I have a large range of cells that I am trying to select easily because it is too large to manually select and copy every time. I am looking for a way to quickly locate the entire range of data and select it. Not to be confused with only selecting every non-empty cell. There are cells within the big range that could be empty, but I also want to include them.
Example is my photo. I want to discover and select all the data that is A1:E7, including the cells in the middle that may be empty. If possible, I would want to de-select the heading as well and only select A2:E7.
So far I have managed to select everything with:
Range("A1").CurrentRegion.Select
But I am unsure how to de-select the top row after that.
Try this
Sub selectWithoutHeaders()
With Range("A1").CurrentRegion
.Offset(1, 0).Resize(.Rows.Count - 1).Select
End With
End Sub
You can use the handy UsedRange to determine the filled area on the sheet without checking each row and column for their last cell coordinates.
With UsedRange, you create a range stretching from A2 to the last cell, and then select it.
Sub Example()
Dim WS As Worksheet
Set WS = ActiveSheet
Dim LastCell As Range
With WS.UsedRange
Set LastCell = .Cells(.Rows.Count, .Columns.Count)
End With
WS.Range("A2", LastCell).Select
End Sub
Here is the Range(Cells(2, 1), Cells(LastRow, LastColumn)).Select version.
Public Function GetLastRowOfSheet(ws As Worksheet) As Long
Dim usedRng As Range
Dim lastRow As Range
Set usedRng = ws.UsedRange
Set lastRow = usedRng.Rows(usedRng.Rows.Count).EntireRow
GetLastRowOfSheet = lastRow.row
End Function
Public Function GetLastColOfSheet(ws As Worksheet) As Long
Dim usedRng As Range
Dim lastRow As Range
Set usedRng = ws.UsedRange
Set lastCol = usedRng.Columns(usedRng.Columns.Count).EntireColumn
GetLastColOfSheet = lastCol.Column
End Function
Sub SelectAllCells()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim lastRow As Long: lastRow = GetLastRowOfSheet(ws)
Dim lastCol As Long: lastCol = GetLastColOfSheet(ws)
Range(Cells(2, 1), Cells(lastRow, lastCol)).Select
End Sub
I would like to compare 2 columns in the same worksheet, search for non-matching values in column A when compared to column D and copy the entire rows of these non-matching values in column A to another worksheet.
Here is a sample of the worksheet:
Therefore, I would like to compare column A with column D, find the values which do not match and copy the entire corresponding rows from Columns A and B to a new worksheet.
*Edit, I forgot to include my code
Dim CopyToRow As Integer
Dim rng1 As Range
Dim rng2 As Range
Dim cell As Range
Dim found As Range
'Start copying data to row 2 in Sheet2 (row counter variable)
CopyToRow = 2
Set rng1 = Range(ActiveSheet.Cells(2, 1), ActiveSheet.Cells(2, 1).End(xlDown))
Set rng2 = Range(ActiveSheet.Cells(4, 2), ActiveSheet.Cells(4, 2).End(xlDown))
For Each cell In rng1
Set found = rng2.Find(what:=cell, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
If Not found Is Nothing Then
cell.EntireRow.Copy Destination:=Sheets("Sheet2").Range("A" & CopyToRow)
CopyToRow = CopyToRow + 1
End If
Next cell
Many thanks and much appreciated!
I agree with Ron Rosenfeld that you should have demonstrated your own attempt. That being said, perhaps this will be of some help to you. Not the most elegant but should work provided you update references to your own sheet names.
Sub SOPractice()
Dim SearchCell As Range 'each value being checked
Dim SearchRng As Range 'column A
Dim LastRow As Long
Dim MatchFound As Range
Dim i As Long: i = 1
LastRow = YourSheet.Range("A" & Rows.Count).End(xlUp).Row
With YourSheet
Set SearchRng = .Range(.Cells(2, 1), .Cells(LastRow, 1))
Application.ScreenUpdating = False
For Each SearchCell In SearchRng
Set MatchFound = .Range("D:D").Find _
(What:=SearchCell.Value, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If MatchFound Is Nothing Then 'No match hence copy to other sheet
.Range(SearchCell.Address, SearchCell.Offset(, 1)).Copy
YourCopyToSheet.Cells(i, 1).PasteSpecial xlPasteAll
i = i + 1
End If
Next SearchCell
End With
Application.ScreenUpdating = True
Application.CutCopyMode = False
End Sub
I have also found a solution, using a Dictionary object:
Dim Cl As Range, Rng As Range, Dic As Object
Set Dic = CreateObject("scripting.dictionary")
With Dic
For Each Cl In MyWorksheet1Name.Range("D2", MyWorksheet1Name.Range("D" & Rows.Count).End(xlUp))
.Item(Cl.Value) = Empty
Next Cl
For Each Cl In MyWorksheet1Name.Range("A2", MyWorksheet1Name.Range("A" & Rows.Count).End(xlUp))
If Not .Exists(Cl.Value) Then
If Rng Is Nothing Then Set Rng = Cl Else Set Rng = Union(Rng, Cl)
End If
Next Cl
End With
If Not Rng Is Nothing Then
Rng.EntireRow.Copy MyWorksheet2Name.Range("A" & Rows.Count).End(xlUp)
End If
Cheers!
I'm trying to dynamically define a range in row like ctrl+down or ctrl+shift+down (to next blank cell) to be used with "For Each itm In rng" statement.
Originally I had it static like this set rng = Range("A4:A10")
So I tried to change it to something like this
Dim rng As Range
Set rng = Range("A4").CurrentRegion.Rows.Count
For Each itm In rng
...
Next itm
I also tried something like this
Set StartCell = Range("A4")
rng = sht.Cells(sht.Rows.Count, StartCell.Column).End(xlUp).Row
But the code doesn't seems to work with "For Each itm In rng" statement
Any help is very much appreciated.
You can use .xlDown, it's the equivalent of pressing ctrl+Shift+down.
Dim rng As Range
Dim lastRow As Long
lastRow = Range("A4").End(xlDown).Row
Set rng = Range("A4:A" & lastRow)
For Each itm In rng
'do something
Next itm
Try this if it helps:
Option Explicit
Sub Test()
Dim LastRow As Long 'to find the last row on your range
Dim MyRange As Range 'to reference the whole range
Dim C As Range 'to loop through your range
With ThisWorkbook.Sheets("MySheet") 'change MySheet for your sheet name
LastRow = .Cells(4, 1).End(xlDown).Row 'last row, how? You go down to the last row and then ctrl + up
Set MyRange = .Range("A4:A" & LastRow) 'dynamic range
For Each C In MyRange
'your code
Next C
End With
End Sub
I have some code in which I am trying to sort the data set in a csv file based on the content of a cell in another (the main) workbook. Then based on this sort, copy a range of visible cells between the first and sixth columns, but with a dynamic last row thus the range will be dynamic. This dynamic range is then pasted into the main sheet, which will then allow me to do further work on this dataset.
Can't seem to get the sort to work or the dynamic range working. I've tried all sorts of variation on the code below and am looking for some inspiration.
Sub Get_OA_Data()
'Find OA data from source SQL file and copy into serial number generator
Dim ws As Worksheet
Dim wkb2 As Workbook
Dim ws2 As Worksheet
Dim rng As Range
Dim rng2 As Range
Dim LastRow As Long
Dim LastColumn As Long
Dim StartCell As Range
'This section sets the workbooks and worksheets to be used for this macro
Set ws = ThisWorkbook.Worksheets("Data Entry")
Set wkb2 = Workbooks.Open("\\srvabdotfpr08\PC_APPS\forum\Gateshead Serialisation\sys_serialisation1.csv")
Set ws2 = wkb2.Worksheets("sys_serialisation1")
Set rng2 = ws.Range("F6")
' This line deletes any content of the cannot assign serial number added previously
ws.Range("I6:I7").ClearContents
'This hides all rows which do not match the desired OA number (found in rng2)
For Each Cell In ws2.Range("A1").End(xlDown)
If Left(Cell.Value, 6) <> rng2.Value Then
Cell.EntireRow.Hidden = True
End If
Next Cell
Set StartCell = ws2.Range("A1")
LastRow = StartCell.SpecialCells(xlCellTypeVisible).Row
LastColumn = StartCell.SpecialCells(xlCellTypeVisible).Column
'This section selects and copies the visible range from csv file into serialisation generator
Set rng = ws2.Range(StartCell.ws2.Cells(LastRow, LastColumn))
rng.Copy
ws.Activate
ws.Range("D12").Select
Selection.PasteSpecial 'Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
Any help would be greatly appreciated, I've bought a couple of books, but none of the stuff in my books is helping with this issue.
P.S I have used very similar code with specific set ranges and it works fine, but this one has me stumped. There may also be an issue with the dataset- which is why I have the LEFT formula in the code (but this seems to work OK).
Try...
Option Explicit
Sub Get_OA_Data()
Dim wkb2 As Workbook
Dim ws As Worksheet, ws2 As Worksheet
Dim rng As Range, xCell As Range
Dim LR As Long, LC As Long, LR2 As Long
Set ws = ThisWorkbook.Worksheets("Data Entry")
Set wkb2 = Workbooks.Open("\\srvabdotfpr08\PC_APPS\forum\Gateshead Serialisation\sys_serialisation1.csv")
Set ws2 = wkb2.Worksheets("sys_serialisation1")
ws.Range("I6:I7").ClearContents
LR2 = ws2.Range("A" & ws.Rows.Count).End(xlUp).Row
For Each xCell In ws2.Range("A1:A" & LR2)
xCell.EntireRow.Hidden = Left(xCell.Value, 6) <> ws.Range("F6")
Next xCell
LR = ws2.Range("A" & ws.Rows.Count).End(xlUp).Row
LC = ws2.Cells(1, ws.Columns.Count).End(xlToLeft).Column
Set rng = ws2.Range(ws2.Cells(1, 1), ws2.Cells(LR, LC))
rng.SpecialCells(xlCellTypeVisible).Copy
ws2.Range("D12").PasteSpecial xlPasteValues
End Sub
I have a workbook with 2 sheets.
Sheet1 contains a list of Product Codes in column A and Column R is Current Stock Level.
Sheet2 contains a list of Product Codes in column A and Column B contains the New Stock Level.
What I want to do is replace the Current Stock Levels in Sheet1 with the New Stock Level from Sheet2.
I found some code on this site already (below) which I have adapted slightly for my purpose and it works fine but only for one Product Code (as it references A1 and B1). What I would like to do is add a Loop so it works down all products in Sheet2 but I'm not sure how to and haven't been able to adapt any similar loops I've found online for this purpose.
Any help would be appreciated, my backup plan is to just do a v-lookup in Sheet1 to bring in the Sheet2 New Stock Level values and then replace the original column but I would like to get this other way working if possible.
Private Sub CommandButton1_Click()
Dim search_range As Range, search_value As Range, _
lastcell As Range, foundcell As Range
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
Set search_range = ws.Range("A1", ws.Range("A" & Rows.Count).End(xlUp))
Set lastcell = search_range.Cells(search_range.Cells.Count)
Set search_value = ThisWorkbook.Sheets("Sheet2").Range("A1")
Set foundcell = search_range.Find(What:=search_value, After:=lastcell,
LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not foundcell Is Nothing Then foundcell.Activate Else MsgBox "Not Found"
ActiveCell.Offset(0, 17).Value = Sheets("Sheet2").Range("B1").Value
End Sub
How about the following:
Private Sub CommandButton1_Click()
Dim search_range As Range, search_value As Range, lastcell As Range, foundcell As Range
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
Set search_range = ws.Range("A1", ws.Range("A" & Rows.Count).End(xlUp))
Set lastcell = search_range.Cells(search_range.Cells.Count)
For i = 1 To lastcell.Row
Set search_value = ThisWorkbook.Sheets("Sheet2").Range("A" & i)
Set foundcell = search_range.Find(What:=search_value, After:=lastcell, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext)
If Not foundcell Is Nothing Then foundcell.Activate Else MsgBox "Not Found"
ActiveCell.Offset(0, 17).Value = Sheets("Sheet2").Range("B" & i).Value
Next i
End Sub
The idea is the following - you have two types of ranges - ranges where you search and ranges where your value should be. They are called Target and Search.
In the code below you loop through all cells in column A of the first worksheets and you look for their value in column A of the second worksheet. If you find the value, you write the value in column B of the second worksheet to the 17. column in the first worksheet:
Private Sub CommandButton1_Click()
Dim targetRange As Range
Dim targetValue As Range
Dim searchRange As Range
Dim lastSearchCell As Range
Dim foundCell As Range
Dim wsTarget As Worksheet
Dim wsSearch As Worksheet
Dim myCell As Range
Set wsTarget = ThisWorkbook.Worksheets(1)
Set wsSearch = ThisWorkbook.Worksheets(2)
With wsTarget
Set targetRange = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
End With
With wsSearch
Set searchRange = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
End With
Set lastSearchCell = searchRange.Cells(searchRange.Cells.Count)
For Each myCell In targetRange
Set foundCell = searchRange.Find(What:=myCell, After:=lastSearchCell).Offset(0, 1)
If Not foundCell Is Nothing Then
myCell.Offset(0, 17) = foundCell
Else
MsgBox "Not Found"
End If
Next myCell
End Sub