Looking for the best way to write the following code. I am currently struggling to make my code as simple and neat as possible. The code effectively takes a range and returns back the range which is non-empty.
Option Explicit
Sub ReturnNonEmptyRange()
Dim testBool As Boolean
Dim i As Long
testBool = True
For i = 2 To 10000:
If Range("G" & i) = "" Then
i = i - 1
testBool = False
End If
If testBool = False Then
Exit For
End If
Next i
MsgBox ("The range is G2:K" & i)
End Sub
Below is some sample code you can try.
The function LastUsedRow is not used, but I'm providing since it can be useful. This will return the last used row in your worksheet.
Using "Range" like you did above will assume you want to use active sheet. I always like to specify a workbook and a sheet so there is no ambiguity.
Sub Test()
' Start at row 1 and and stop when first blank cell found
Dim wks As Worksheet: Set wks = ThisWorkbook.Worksheets("Sheet1")
Dim row As Long
' Option 1: using column numbers
row = 1
Dim col As Long: col = 7 ' G
Do Until wks.Cells(row + 1, col).Value = ""
row = row + 1
Loop
MsgBox ("Last used row (in column): " & row) ' assumes something in row 1
' Option 2: using column letters
row = 1
Dim colLetter As String: colLetter = "G"
Do Until wks.Range(colLetter & row + 1).Value = ""
row = row + 1
Loop
MsgBox ("Last used row (in column): " & row) ' assumes something in row 1
End Sub
Public Function LastUsedRow(wks As Worksheet) As Long
Dim rng As Range: Set rng = wks.UsedRange ' Excel will recalc used range
LastUsedRow = rng.row + rng.Rows.Count - 1
End Function
I think your method only works if your none-empty range is consecutive. Suppose G2:G10 is non-empty, G11 is empty and G12:G20 is non-empty. Your code would come to i=11 and return G2:K10 as the non-empty range.
A more reliable, and quicker way to find the last non-empty cell (before row 1000) would be this:
range("G1000").End(xlUp).row
This will give you the first non-empty row in column G above row 1000. If row 1000 is non-empty however, it would search upwards for the last non-empty row. so you might want to change it to:
Range("G" & Rows.Count).End(xlUp).Row
This will find the last non-empty row, starting from the bottom of the worksheet.
How about combining the loop's exit conditions all into the loop control header.
I also would explicitly access the range()'s value to be more clear in the code and check the string length to be zero.
Option Explicit
Sub ReturnNonEmptyRange()
Dim testBool As Boolean
Dim i As Long
testBool = True
i = 2
While (i < 10000) And (Len(Range("G" & i).Value) <> 0)
i = i + 1
Wend
MsgBox ("The range is G2:K" & i)
End Sub
In the case this was an Array, one could not use Range("G" & Rows.Count).End(xlUp).Row. I believe #Siddharth provided a good solution. The downside being it will stop at a non- empty row.
Sub ReturnNonEmptyRange()
Dim i As Long
For i = 2 To 10000:
If Len(Trim(Range("G" & i).Value)) = 0 Then Exit For
Next i
MsgBox ("The range is G2:K" & i - 1)
End Sub
Related
I have a financial data with serial numbers linked to asset. The serial numbers are listed in cell through line breaks, i.e. there could 3,4,5 etc. serial no in a cell. So, the idea is copy and insert rows based on how many serial numbers are linked to asset in selected range. i.e. if there 4 serial no, then row should be split into 4 rows. The issue my code is that once I'm selected the range to be split, no matter that 3 or more serial numbers exist in first row it's slit into two rows, but the rest cells in range are split correctly. Not sure why the cycle within first cell in a range ends wrong.
Public Sub separate_line_range()
Dim target_col As Range
myTitle = "Select cells to be split"
Set target_col = Application.Selection
Set target_col = Application.InputBox("Select a range of cells that you want to split", myTitle, target_col.Address, Type:=8)
ColLastRow = target_col
Application.ScreenUpdating = False
For Each rng In target_col
If InStr(rng.Value, vbLf) Then
rng.EntireRow.Copy
rng.EntireRow.Insert
rng.Offset(-1, 0) = Mid(rng.Value, 1, InStr(rng.Value, vbLf) - 1)
rng.Value = Mid(rng.Value, Len(rng.Offset(-1, 0).Value) + 2, Len(rng.Value))
End If
Next
ColLastRow2 = target_col
For Each Rng2 In target_col
If Len(Rng2) = 0 Then
Rng2.EntireRow.Delete
End If
Next
Application.ScreenUpdating = True
End Sub
Please find imagine below:
I don't exactly know your task, so I put something relatively close to your task.
The issue of not correctly loop through all row is because the "RNG" you selected will not be resized after each insert row.
e.g. You are selecting row A1:C20, and there are two row added. Now the #19 and #20 are now A21:C21 & A22:C22. But the RNG is still A1:C20. The final two row will not be within the loop.
To solve your issue,
Use For i = LastRow to First Row Step -1 (Next) instead of For Each (Loop)
Here is something I do similar to your task (What I believe)
Sub Insertrow()
Dim i As Integer
Dim Lastrow As Integer
Lastrow = Worksheets("FMS1").Cells(1, 12)
For i = Lastrow To 1 Step -1
If Worksheets("FMS1").Range("J" & i) <> Worksheets("FMS1").Range("J" & i + 1) Then
Worksheets("FMS1").Range("J" & i + 1).EntireRow.Insert
Else
End If
Next
End Sub
Imagine the following data
and the following code
Option Explicit
Public Sub SplitLineBreaksIntoCells()
Const MyTitle As String = "Select cells to be split" ' define it as constant
Dim TargetCol As Range
On Error Resume Next ' next line errors if user presses cancel
Set TargetCol = Application.InputBox("Select a range of cells that you want to split", MyTitle, Application.Selection.Address, Type:=8)
On Error GoTo 0
If TargetCol Is Nothing Then
' User pressed cancel
Exit Sub
End If
Dim iRow As Long
For iRow = TargetCol.Rows.Count To 1 Step -1 ' loop from bottom to top when adding rows or row counting goes wrong.
Dim Cell As Range ' get current cell
Set Cell = TargetCol(iRow)
Dim LinesInCell() As String ' split data in cell by line break int array
LinesInCell = Split(Cell.Value, vbLf)
Dim LinesCount As Long ' get amount of lines in that cell
LinesCount = UBound(LinesInCell) + 1
' insert one cell less (one cell can be re-used)
Cell.Resize(RowSize:=LinesCount - 1).EntireRow.Insert Shift:=xlShiftDown
' inert the values from the spitted array
Cell.Offset(RowOffset:=-LinesCount + 1).Resize(RowSize:=LinesCount).Value = Application.Transpose(LinesInCell)
Next iRow
End Sub
You will get this as result:
I am using EntireRow.Delete to Delete some rows in my Excel Programm. It works very well!
I need a way to delete the EntireRow but I have to exclude some Columns at the end of that row.
Is it possible to call EntireRow.Delete and exclude some Columns? Here is my Code:
Dim j As Long
Dim count As Long
count = 0
Dim searchRng As Range: Set searchRng = Range("Q9:Q5000")
Dim Cell As Range
For j = searchRng.count To 1 Step -1
If ((searchRng(j).Value < CDate(TextBoxDelete.Value)) And (searchRng(j).Value <> "")) Then
count = count + 1
Debug.Print ("Cell " & count & ": " & searchRng(j).Value & " txtbox: " & TextBoxDelete.Value)
' searchRng(j).EntireRow(, -6).Delete
searchRng(j).EntireRow.Delete ' Original - works but I need to "cut off" the last columns
' searchRng(j).EntireRow.Cells(, 19).Delete
' Debug.Print searchRng.EntireRow.Offset(, 7)
End If
Next j
I have tried to use some Offset and other Functions on that line but with no luck. Does anyone know how I could change it so it deletes the entire Row but keeps the columns at the back lets say from Column "T" in place and does not delete those.
The problem is that EntireRow as the word says is the entire row. But you can use Resize to cut it off at a specific column.
Try the following
Option Explicit
Public Sub test()
Dim ws As Worksheet
Set ws = ActiveSheet ' better define your sheet like ThisWorkbook.Worksheets("Sheet1")
Dim LastRow As Long ' get last used row in column Q so you only loop through actual data
LastRow = ws.Cells(ws.Rows.Count, "Q").End(xlUp).Row
Dim searchRng As Range
Set searchRng = ws.Range("Q9", "Q" & LastRow)
Dim Count As Long
Dim j As Long
For j = searchRng.Count To 1 Step -1
If (searchRng(j).Value < CDate(TextBoxDelete.Value)) And (searchRng(j).Value <> "") Then
Count = Count + 1
' clear content from column A to Q
searchRng(j).EntireRow.Resize(ColumnSize:=19).ClearContents
' check if entire row is empty
If searchRng(j).Offset(ColumnOffset:=ws.Columns.Count - searchRng(j).Column).End(xlToLeft).Column = 1 Then
' row is empty delete it
searchRng(j).EntireRow.Delete xlShiftUp
End If
End If
Next j
End Sub
This
searchRng(j).Offset(ColumnOffset:=ws.Columns.Count - searchRng(j).Column)
jumps to the very last cell in that row and then uses .End(xlToLeft) to go left until it finds a cell with data. So if the column number is 1 that means the entire row is empty and can be deleted.
So in the example below the red cells trigger the deletion
and it ends up with
As you can see the row with 1 was cleared until column T because there is more data behind, but the row with 3 was entirely deleted because it was totally empty after clearing it from A to S.
\ Edit according comment
If you don't want empty cells use
If (searchRng(j).Value < CDate(TextBoxDelete.Value)) And (searchRng(j).Value <> "") Then
Count = Count + 1
' clear content from column A to Q
searchRng(j).EntireRow.Resize(ColumnSize:=19).Delete xlShiftUp
End If
I have a worksheet in Excel where the E column contains the velocity of a vehicle. The first few rows have 0 velocity until the vehicle starts moving. I want to find the range of rows at the start of the sheet where the vehicle is in idle and remove them, as I have no real reason to keep these rows
I found this code to find the range of rows where a specific text is stored in one of the cells:
Private Sub DeleteIdleRows()
Dim idleStartRow as Long, idleEndRow as Long
With ActiveSheet
idleStartRow = .Range("E:E").Find(what:="0", after:=.Range("E3")).Row
idleEndRow = .Range("E:E").Find(what:="0", after:=.Range("E3"), searchdirection:=xlPrevious).Row
End With
End Sub
The code gives no errors, but it finds the absolute last instance of 0, and not the last 0 in the first "set". Is there a way for me to narrow down this search function to stop as soon as the next instance is not 0?
Option Explicit
Private Sub DeleteIdleRows()
Dim idleStartRow As Long
Dim idleEndRow As Long
Dim i As Long
idleStartRow = 0
With ActiveSheet
For i = 1 To Cells(Rows.Count, "E").End(xlUp).Row
If Range("E" & i).Value2 = 0 And idleStartRow = 0 And IsEmpty(Range("E" & i).Value2) = False Then idleStartRow = i
If Range("E" & i + 1).Value <> 0 And idleStartRow <> 0 Then
idleEndRow = i
Exit For
End If
Next
End With
MsgBox idleStartRow
MsgBox idleEndRow
End Sub
I have modified your code little bit and is working fine. Also note that in your formula when you are using find function, it will also return the row even if the value contains zero (Example: 30)
I have two ranges as showed in this picture.
I'm trying to write a VBA macro that successively selects a single cell in the first range (“B23, F27”) , copies the selected cell's value, then selects a random cell in the second range (“G23, K27”), and pastes the first cell's value into the randomly selected cell in the second range.
This should repeat until every cell from the first range has been copied, or every cell in the second range is filled with a new value. In this example both outcomes are equivalent as both ranges have the same number of cells (25).
The result should be like the second image.
I tried to assign the first range to an array and then pick a random value from this array and paste it to the second range.
I also tried to extract unique values from the first range, build a dictionary with it then pick a random cell from the second range and a random value from the dictionary and paste it.
Later I tried again using the VBA syntax “with range” and f"or each cell in range" but I can’t just come up with something that actually works. Sometimes the second range is filled by various values, but not as intended.
First example: this one just does not work
Sub fillrange()
Dim empty As Boolean
'This part checks if every cell in the first range as a value in it
For Each Cell In Range("B23", "F27")
If Cell.Value = "" Then
empty = True
End If
Next
'If every cell is filled then
If empty Then
Exit Sub
Else:
With ThisWorkbook.Worksheets("Sheet1)").Range("B23", "F27")
.Cells(Application.WorksheetFunction.RandBetween(1, 25)).Select
.Copy 'the cell select works, but it will copy all range
'This does not work
'For Each Cell In Range("G23", "K27")
'Cells(Application.WorksheetFunction.RandBetween(1, 25)).Select
'.PasteSpecial Paste:=xlPasteValues
'Next
End With
End If
End Sub
Second example: it fills the range but with wrong values
Sub fillrange2()
Dim empty As Boolean
For Each cell In Range("B23", "F27")
If cell.Value = "" Then
empty = True
'This part checks if every cell in the first range as a value in it
Exit For
End If
Next cell
If empty Then
Exit Sub
Else:
Dim ws As Worksheet
Dim lRow As Long, i As Long
Dim col As New Collection, itm As Variant
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 1 To lRow
On Error Resume Next
col.Add .Range("B23", "F27").Value, CStr(.Range("A" & i).Value)
On Error GoTo 0
Next i
End With
Dim MyAr() As Variant
ReDim MyAr(0 To (col.Count - 1))
For i = 1 To col.Count
MyAr(i - 1) = col.Item(i)
Next
For Each cell In Range("G23", "K27")
cell.Value = Application.WorksheetFunction.RandBetween(LBound(MyAr), UBound(MyAr))
Next
End If
End Sub
Third example: as the second example, it fills the range but with wrong values
Sub fillrange3()
Dim MyAr() As Variant
MyAr = Range("B23", "F27")
For Each cell In Range("G23", "K27")
cell.Value = Application.WorksheetFunction.RandBetween(LBound(MyAr), UBound(MyAr))
Next
End Sub
Maybe something like this ?
Sub test()
Set Rng = Range("G23:K27")
n = 1
totCell = 25
Set oFill = Range("G23")
Set oSource = Range("B23")
For i = 1 To 5
oFill.Value = "X" & n
oFill.AutoFill Destination:=Range(oFill, oFill.Offset(4, 0)), Type:=xlFillSeries
Set oFill = oFill.Offset(0, 1)
n = n + 5
Next i
For i = 1 To 5
Do
RndVal = Int((totCell - 1 + 1) * Rnd + 1)
xVal = "X" & RndVal
Set C = Rng.Find(xVal, lookat:=xlWhole)
If Not C Is Nothing Then
C.Value = oSource.Value
Set oSource = oSource.Offset(1, 0)
check = check + 1
If check = 5 Then Exit Do
End If
Loop
Set oSource = oSource.Offset(-5, 1)
check = 0
Next i
End Sub
I cheat by making a preparation for the range G23 to K27 fill with X1 to X25 in the first for i = 1 to 5.
The second for i = 1 to 5 is to offset from column B to G.
The Do - Loop is to generate random number between 1 to 25.
If the generated number is found then the found cell has the value from the "source",
if not found, it loop until the generated number is found 5 times (hence also the found cell is fill with 5 different source). Then before the next i, the "source" cell is offset to the next column.
This if I'm not wrong to get what you mean.
Here's another approach, just for a bit of variety.
Sub x()
Dim r1 As Range, r2 As Range, i As Long
Dim r As Long, c As Long
Set r1 = Range("B23").Resize(5, 5) 'define our two ranges
Set r2 = Range("G23").Resize(5, 5)
r2.ClearContents 'clear output range
With WorksheetFunction
Do Until .Count(r2) = r2.Count 'loop until output range filled
r = .RandBetween(1, 25) 'random output cell number
If .CountIf(r2, r1.Cells(i)) = 0 Then 'if not in output range already
If r2.Cells(r) = vbNullString Then 'if random cell empty
r2.Cells(r).Value = r1.Cells(i).Value 'transfer value
i = i + 1
End If
End If
Loop
End With
End Sub
I am trying to write a code that adds in data from my excel sheet if the item the user selects is equal to the range in J. This works perfectly if the range in J is filled in with all the data, but how do I get the row to still count all the way through the last filled cell if there are blanks in between? I attached a picture to show what I mean.
.
I would want to count the rows all the way down to the last "Gold". Right now it only counts to the second.
Private Sub cboName_Click() 'only get values that are assigned
Dim j As Integer, k As Integer, i As Integer
Me.lstProvider.Clear
i = 0
Worksheets("Biopsy Log").Select
For j = 1 To Range("J2", Range("J1").End(xlDown)).Rows.count
If Range("J2", Range("J2").End(xlDown)).Cells(j) = Me.cboName.Value Then
If Range("C2", Range("C2").End(xlDown)).Cells(j) = "Assigned" Then
With Me.lstProvider
.AddItem
For k = 0 To 5
.List(i, k) = Range("A" & j + 1).Offset(0, k)
Next
End With
i = i + 1
End If
End If
Next
End Sub
Instead of For j = 1 To Range("J2", Range("J1").End(xlDown)).Rows.count use Range("J" & Rows.Count).End(xlUp).Row (assuming GOLD is in column J). The code does the opposite of xlDown. It goes down to the last row of the sheet (Rows.count) and moves up until it find the first non-blank cell.
Instead of using xlDown, try to use xlUp from the bottom to get the last row for correct range:
Dim sht As Worksheet
Set sht = Worksheets("Biopsy Log")
For j = 1 To sht.Range("J" & sht.Rows.Count).End(xlUp).Row
If sht.Range(...)
Qualifying Range calls with an explicit Worksheet object makes your code more robust.