I want to copy data from sheet1 to sheet2, row number 9 with one condition. The data should be inserted to the next empty cell to the right.
I wrote a procedure that is a bit more general than #FahmiYogyas question.
Assume the source range is a named range of one or more cells (here NamedRange1) and the top left cell of the destination is a second named range (here NamedRange2).
Option Explicit
'
' start this as example
'
Sub test1()
copyData Range("NamedRange1"), Range("NamedRange2")
End Sub
'
'
'
Sub copyData(sourceRange As Range, destinationRange As Range)
Dim myCell As Range
Dim columnOffset As Long
Dim firstCell As Range
Dim isFirst As Boolean
'
' increase the column offset until the first destination cell is empty
'
Do While Not IsEmpty(destinationRange.Offset(0, columnOffset))
columnOffset = columnOffset + 1
Loop
isFirst = True
'
' now get the value of the source cells
' and insert it at the destination position
' offset is used to allow for arbitrary source ranges
For Each myCell In sourceRange
If isFirst Then
Set firstCell = myCell
isFirst = False
End If
destinationRange.Offset(myCell.Row - firstCell.Row, myCell.Column - firstCell.Column + columnOffset).Value = myCell.Value
Next
End Sub
Related
I need a VBA code, that will allow me to select and copy custom number of visible rows only.
For example: I filtered a column data, and the count of all the visible cells is 1000. However, I want to copy only the first 800 visible cells only out of the 1000 visible cells.
One idea is to get all visible cells using SpecialCells(xlCellTypeVisible) and then loop through and collect them one by one using Application.Union to limit them to your desired amount.
Option Explicit
Public Sub Example()
Dim Top800Cells As Range
Set Top800Cells = GetTopVisibleRows(OfRange:=Range("A:A"), TopAmount:=800)
Top800Cells.Select
End Sub
Public Function GetTopVisibleRows(ByVal OfRange As Range, ByVal TopAmount As Long) As Range
Dim VisibleCells As Range
Set VisibleCells = OfRange.SpecialCells(xlCellTypeVisible)
If VisibleCells Is Nothing Then
Exit Function
End If
Dim TopCells As Range
Dim Count As Long
Dim Row As Range
For Each Row In VisibleCells.Rows
If TopCells Is Nothing Then
Set TopCells = Row
Else
Set TopCells = Application.Union(TopCells, Row)
End If
Count = Count + 1
If Count = TopAmount Then Exit For
Next Row
Set GetTopVisibleRows = TopCells
End Function
If you want to use it as a UDF (user defined function) in a formula SpecialCells(xlCellTypeVisible) is known to fail there (see SpecialCells(xlCellTypeVisible) not working in UDF). And you need to check visibility yourselft:
Public Function GetTopVisibleRows(ByVal OfRange As Range, ByVal TopAmount As Long) As Range
Dim TopCells As Range
Dim Count As Long
Dim Row As Range
For Each Row In OfRange.Rows
If Not Row.EntireRow.Hidden Then
If TopCells Is Nothing Then
Set TopCells = Row
Else
Set TopCells = Application.Union(TopCells, Row)
End If
Count = Count + 1
If Count = TopAmount Then Exit For
End If
Next Row
Set GetTopVisibleRows = TopCells
End Function
Copy First n Rows of SpecialCells(xlCellTypeVisible)
This is usually done to more columns as illustrated in the code.
To apply it just to column A, replace Set rg = ws.Range("A1").CurrentRegion with
Set rg = ws.Range("A1").CurrentRegion.Columns(1)
assuming that the header is in the first worksheet row.
In a nutshell, it loops through the rows (rrg) of each area (arg) of the range (MultiRange, dvrg) counting each row (r) and when it hits the 'mark' (DataRowsCount), it uses this row (Set SetMultiRangeRow = rrg, lrrg) and the first row (frrg) as arguments in the range property to set the required range and reapply the same type of SpecialCells to finally reference the required amount of rows.
Sub ReferenceFirstMultiRangeRows()
' Define constants
Const CriteriaColumn As Long = 1
Const CriteriaString As String = "Yes"
Const DataRowsCount As Long = 800
' Reference the worksheet ('ws').
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
If ws.AutoFilterMode Then ws.AutoFilterMode = False
' Reference the ranges.
Dim rg As Range ' the range (has headers)
Set rg = ws.Range("A1").CurrentRegion ' you may need to use another way!
Dim drg As Range ' the data range (no headers)
Set drg = rg.Resize(rg.Rows.Count - 1).Offset(1)
' Apply the auto filter to the range.
rg.AutoFilter CriteriaColumn, CriteriaString
' Attempt to reference the visible data range ('vdrg').
Dim vdrg As Range
On Error Resume Next
Set vdrg = drg.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
' Reference the required amount of visible rows ('vdrg').
' Reference the partial range ('vdrg') from the first row
' to the DataRowsCount-th row of the visible range
' and reapply special cells to this range.
If Not vdrg Is Nothing Then ' filtered rows found
Dim lrrg As Range: Set lrrg = SetMultiRangeRow(vdrg, DataRowsCount)
If Not lrrg Is Nothing Then ' there are more rows than 'DataRowsCount'
Dim frrg As Range: Set frrg = vdrg.Rows(1)
Set vdrg = ws.Range(frrg, lrrg).SpecialCells(xlCellTypeVisible)
'Else ' the visible data range is already set; do nothing
End If
'Else ' no filtered rows found; do nothing
End If
ws.AutoFilterMode = False ' remove the auto filter
If vdrg Is Nothing Then
MsgBox "No filtered rows.", vbExclamation
Exit Sub
End If
' Continue using vdrg e.g.:
Debug.Print vdrg.Address ' only the first <=257 characters of the address
'vdrg.Select
'vdrg.Copy Sheet2.Range("A2")
End Sub
Function SetMultiRangeRow( _
ByVal MultiRange As Range, _
ByVal MaxRowNumber As Long) _
As Range
Dim rCount As Long
rCount = MultiRange.Cells.CountLarge / MultiRange.Columns.Count
If rCount < MaxRowNumber Then Exit Function
Dim arg As Range
Dim rrg As Range
Dim r As Long
Dim lrrg As Range
For Each arg In MultiRange.Areas
For Each rrg In arg.Rows
r = r + 1
If r = MaxRowNumber Then
Set SetMultiRangeRow = rrg
Exit For
End If
Next rrg
Next arg
End Function
I have managed to insert rows based on cell value for instance if A1 cell is 20, I run the macro, 20 rows appear under A1, those rows are blank right, I need the 20 new cells below A1 to be number 1 to 20 ( the number in A1) let me know if possible.
Cheers Adrien
Try this:
Sub counter()
Dim i as integer
for i = 2 to cells(1, 1) + 1
cells(i, 1) = i - 1
next i
End Sub
Insert an Integer Sequence Below a Cell
A Basic Example For the Active Sheet
Note that this doesn't insert rows, it just writes the integer sequence to the cells below A1.
Sub IntegersBelow()
With Range("A1")
.Resize(.Value).Offset(1).Value _
= .Worksheet.Evaluate("ROW(1:" & CStr(.Value) & ")")
End With
End Sub
Applied to Your Actual Use Case
Adjust the values in the constants section.
Sub InsertIntegersBelow()
' Use constants to change their values in one place instead
' of searching for them in the code (each may be used multiple times).
Const wsName As String = "Sheet1"
Const fRow As Long = 3
Const Col As String = "E"
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing the code
' Reference the worksheet ('ws').
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
' Calculate the last row ('lRow'),
' the row of the last non-empty cell in the column.
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, Col).End(xlUp).Row
' Validate the last row.
If lRow < fRow Then
MsgBox "No data in column range.", vbInformation
Exit Sub
End If
Dim cCell As Range ' Current Cell
Dim cValue As Variant ' Current Cell Value
Dim r As Long ' Current Row
For r = lRow To fRow Step -1 ' loop backwards
Set cCell = ws.Cells(r, Col) ' reference the current cell...
cValue = cCell.Value ' ... and write its value to a variable
If VarType(cValue) = vbDouble Then ' is a number
cValue = CLng(cValue) ' ensure whole number
If cValue > 0 Then ' greater than 0
' Insert the rows.
cCell.Offset(1).Resize(cValue) _
.EntireRow.Insert xlShiftDown, xlFormatFromLeftOrAbove
With cCell.Offset(1).Resize(cValue)
' Write the values.
.Value = ws.Evaluate("ROW(1:" & cValue & ")")
' Apply formatting.
.ClearFormats
.Font.Bold = True
End With
'Else ' less than or equal to zero; do nothing
End If
'Else ' is not a number
End If
Next r
MsgBox "Rows inserted.", vbInformation
End Sub
The code works when the criteria exists. I get an error when the criteria doesn't exist.
' Define constants.
Const srcName As String = "wfm_rawdata"
Const srcFirst As String = "D2" ' Location for Group
Const dstName As String = "bond_insurance"
Const dstFirst As String = "A2" ' do not change the 'A' (entire row).
'This function will transfer rows from one worksheet to another worksheet
' if the value = specified critiera
' Define workbook.
Dim wb As Workbook: Set wb = ActiveWorkbook ' Workbook containing this code.
' Define Source Range
Dim LastRow As Long
Dim srg As Range
' Define worksheet and column am working on and
' getting the range of last used cell using(LastRow)
With wb.Worksheets(srcName).Range(srcFirst)
LastRow = .Offset(.Worksheet.Rows.Count - .Row).End(xlUp).Row
Set srg = .Resize(LastRow - .Row + 1, 10)
End With
'Combine' critical cells into a range.
Dim brg As Range ' Built Range --> Range in the new sheet
Dim cel As Range ' Current Cell Range --> Range in the current sheet(rawdata)
'for every cell in group within wfm_rawdata sheet if the value = GO
For Each cel In srg.Cells
If cel.Value = "BOND INSURANCE" Then
' If the range in the new sheet have nothing then
' add specific criteria from the group in wfm_rawdata
If brg Is Nothing Then
Set brg = cel
' if there is range in there combine the new and
' old range together using -> Union function
Else
Set brg = Union(brg, cel)
End If
End If
Next cel
Application.ScreenUpdating = False
' Copy and delete critical rows of Source Range.
With wb.Worksheets(dstName).Range(dstFirst)
.Resize(.Worksheet.Rows.Count - .Row + 1, _
.Worksheet.Columns.Count).clear
Set brg = brg.EntireRow ' 'Convert' cells into rows.
brg.Copy .Offset ' Copy. 'Offset' because range is in 'With'.
brg.Delete ' Delete.
End With
How can I use a Boolean or other function to bypass the above code if the criteria doesn't exist?
For example if criteria "dog" exists then run the code and if it doesn't exist bypass the code.
I use this code to run three modules with code similar to the top code.
Sub master()
Call report1
Call report2
Call report3
End Sub
One you've assigned srg you can use Match() to check whether it contains any instances of the term you're interested in:
'...
'...
' Define worksheet and column am working on and getting the range of last used cell using(LastRow)
With wb.Worksheets(srcName).Range(srcFirst)
LastRow = .Offset(.Worksheet.Rows.Count - .Row).End(xlUp).Row
Set srg = .Resize(LastRow - .Row + 1, 10)
End With
'Exit if "BOND INSURANCE" is not found in `srg`
If IsError(Application.Match("BOND INSURANCE", srg, 0)) Then Exit Sub
'...
'...
In the picture below, I'm trying to hide the rows that are empty in a certain cells (e.g. Row 39 to Row 48). Is is possible to do it in one click? I'm planning of doing it with VBA.
This is the formula that I'm currently using but the thing is the cells that I want to hide may not start at row 39 or ends at row 48, it depends on the data.
Sub HideRows()
Dim ws As Worksheet
For Each ws In Worksheets(Array("NAMES", "AUGUST"))
'ws.Rows("39:48").Hidden = True
Next
End Sub
Hide 'Empty' Rows
This is a slightly different approach:
uses Option Explicit
uses constants and variables
uses For Each...Next loops for both, worksheets and cells
qualifies all objects (e.g. ws.Cells or rg.Cells, not just Cells)
combines empty cells into a range
unhides all rows in one go, then hides the 'empty' rows in another (go)
Option Explicit
Sub HideRows()
Const StartRow As Long = 9
Const EndRow As Long = 89
Const ColNum As Long = 3
Dim WorksheetNames As Variant
WorksheetNames = Array("NAMES", "AUGUST") ' add more
Dim ws As Worksheet ' Current Worksheet
Dim rg As Range ' Current Range
Dim hrg As Range ' Current Hide Range
Dim cCell As Range ' Current Cell in Range
' Loop through the worksheets in the workbook containing this code.
For Each ws In ThisWorkbook.Worksheets(WorksheetNames)
' Create a reference to the range of the current worksheet.
Set rg = ws.Range(ws.Cells(StartRow, ColNum), ws.Cells(EndRow, ColNum))
' or using resize:
'Set rg = ws.Cells(StartRow, ColNum).Resize(EndRow - StartRow + 1)
' Loop through the cells of the current range.
For Each cCell In rg.Cells
If IsEmpty(cCell) Then ' cell is empty
' Combine ('add') the current cell into the hide range.
If Not hrg Is Nothing Then ' for all except the first
Set hrg = Union(hrg, cCell)
Else ' for the first
Set hrg = cCell
End If
'Else ' cell is not empty - do nothing
End If
Next cCell
' Unhide all rows of the current range of the current worksheet.
rg.EntireRow.Hidden = False
If Not hrg Is Nothing Then ' there are combined cells
' Hide the rows of the hide range.
hrg.EntireRow.Hidden = True
' Reset the hide range variable for the next worksheet.
' Also, note that 'Union' works only with ranges from one worksheet.
Set hrg = Nothing
'Else ' there are no combined cells - do nothing
End If
Next ws
End Sub
I already made it. Below is the script that I used.
Sub HideRows()
Dim ws As Worksheet
For Each ws In Worksheets(Array("NAMES", "AUGUST"))
StartRow = 9
EndRow = 89
ColNum = 3
For i = StartRow To EndRow
If Not IsEmpty(Cells(i, ColNum).Value) Then
ws.Cells(i, ColNum).EntireRow.Hidden = False
Else
ws.Cells(i, ColNum).EntireRow.Hidden = True
End If
Next i
Next
End Sub
This question already has answers here:
Find last used cell in Excel VBA
(14 answers)
Closed 1 year ago.
I need to find the first blank cell in a column. The solution for this is easy assuming there are 2 or more filled cells in the column.
Range("A1").End(xlDown).Offset(1, 0).Select
This stops working if the only populated cell is A1 or if A1 is blank.
In these cases it will select the last cell in the workbook.
Is there any work around that will always select the first blank cell in the column even if that cell happens to be A1 or A2?
Here is a solution that tests if the cell we find is empty and if A1 is empty:
Dim Rng As Range
Set Rng = Range("A1").End(xlDown)
If Rng.Value = "" Then
If Range("A1").Value = "" Then
Range("A1").Select
Else
Range("A2").Select
End If
Else
Rng.Offset(1, 0).Select
End If
In the comment you write that you don't like the order of the code, here is another example:
If Range("A1").Value = "" Then
Range("A1").Select
ElseIf Range("A2").Value = "" Then
Range("A2").Select
Else
Range("A1").End(xlDown).Offset(1, 0).Select
End If
And here is another example that avoids the use of End() and Offset():
Dim Cnt As Long
Cnt = ActiveSheet.UsedRange.Rows.Count
If Cnt = 1 And Range("A1").Value = "" Then Cnt = 0
Range("A" & Cnt + 1).Select
If you add a header row, then this example works:
Range("A" & ActiveSheet.UsedRange.Rows.Count + 1).Select
I always include a header row in all sheets with tabular data, to limit special cases - it's also more user friendly.
Find First Empty Cell by Looping
Empty
Except looping through cells, there are various more or less reliable ways to do it.
If there are hidden rows or columns, many of them will not work.
Even worse, if the worksheet is filtered, probably most of them will not work.
The Basic Loop
If you loop through the cells and test each one of them, you will surely get the correct result.
Function RefFirstEmptyCellInColumnBasic( _
ByVal FirstCell As Range) _
As Range
' Validate the given range ('FirstCell').
If FirstCell Is Nothing Then Exit Function
' Create a reference to the Column Range ('crg').
With FirstCell.Cells(1)
Dim crg As Range: Set crg = .Resize(.Worksheet.Rows.Count - .Row + 1)
End With
' Loop.
Dim cCell As Range
' Loop through the cells of the Column Range...
For Each cCell In crg.Cells
' ... until an empty cell is found.
If IsEmpty(cCell) Then
' Create a reference to the current cell.
Set RefFirstEmptyCellInColumnBasic = cCell
Exit Function
End If
Next cCell
End Function
The issue is that it may take a long time. It will 'behave' for a few thousand rows but e.g. if the first empty cell is the last cell in the column, the previous code takes 'forever' (5s) on my machine.
Loop in Memory (Array)
To remedy this, you can introduce an array into the previous code which will reduce the execution time ten times (0.5s). (Note that it will roughly take 0.05s each time for just writing the values to the array.)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the top-most empty cell
' in the one-column range from the first cell of a range
' ('FirstCell') through the last cell in its column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefFirstEmptyCellInColumn( _
ByVal FirstCell As Range) _
As Range
' Validate the given range ('FirstCell').
If FirstCell Is Nothing Then Exit Function
' Create a reference to the Column Range ('crg').
With FirstCell.Cells(1)
Dim crg As Range: Set crg = .Resize(.Worksheet.Rows.Count - .Row + 1)
End With
' Write the values from the Column Range to the Column Data Array ('cData').
Dim cData As Variant
If crg.Rows.Count = 1 Then ' only one cell
ReDim cData(1 To 1, 1 To 1): cData(1, 1) = crg.Value
Else
cData = crg.Value
End If
' Loop.
Dim r As Long
' Loop through the elements of the Column Data Array...
For r = 1 To UBound(cData, 1)
' ... until an empty value is found.
If IsEmpty(cData(r, 1)) Then
' Create a reference to the r-th cell of the Column Range.
Set RefFirstEmptyCellInColumn = crg.Cells(r)
Exit Function
End If
Next r
End Function
The Test
To test the previous you can do the following.
Sub RefFirstEmptyCellInColumnTEST()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim fCell As Range: Set fCell = ws.Range("A3")
' Empty
Dim feCell As Range: Set feCell = RefFirstEmptyCellInColumn(fCell)
If Not feCell Is Nothing Then
Debug.Print feCell.Address(0, 0)
End If
End Sub
Blank
You can do the same for blank cells i.e. empty cells or cells containing a single quote (') or cells containing formulas evaluating to "". Note that cells containing spaces are neither blank nor empty.
Function RefFirstBlankCellInColumnBasic( _
ByVal FirstCell As Range) _
As Range ' (Empty, ="" and ')
' Validate the given range ('FirstCell').
If FirstCell Is Nothing Then Exit Function
' Create a reference to the Column Range ('crg').
With FirstCell.Cells(1)
Dim crg As Range: Set crg = .Resize(.Worksheet.Rows.Count - .Row + 1)
End With
' Loop.
Dim cCell As Range
' Loop through the cells of the Column Range...
For Each cCell In crg.Cells
' (exclude cell containing error value)
If Not IsError(cCell) Then
' ... until a blank cell is found.
If Len(cCell.Value) = 0 Then
' Create a reference to the current cell.
Set RefFirstBlankCellInColumnBasic = cCell
Exit Function
End If
End If
Next cCell
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the top-most blank cell
' in the one-column range from the first cell of a range
' ('FirstCell') through the last cell in its column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefFirstBlankCellInColumn( _
ByVal FirstCell As Range) _
As Range ' (Empty, ="" and ')
' Validate the given range ('FirstCell').
If FirstCell Is Nothing Then Exit Function
' Create a reference to the Column Range ('crg').
With FirstCell.Cells(1)
Dim crg As Range: Set crg = .Resize(.Worksheet.Rows.Count - .Row + 1)
End With
' Write the values from the Column Range to the Column Data Array ('cData').
Dim cData As Variant
If crg.Rows.Count = 1 Then ' only one cell
ReDim cData(1 To 1, 1 To 1): cData(1, 1) = crg.Value
Else
cData = crg.Value
End If
' Loop.
Dim r As Long
' Loop through the elements of the Column Data Array...
For r = 1 To UBound(cData, 1)
' (exclude error values)
If Not IsError(cData(r, 1)) Then
' ... until a blank is found.
If Len(cData(r, 1)) = 0 Then
' Create a reference to the r-th cell of the Column Range.
Set RefFirstBlankCellInColumn = crg.Cells(r)
Exit Function
End If
End If
Next r
End Function
Sub RefFirstBlankCellInColumnTEST()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim fCell As Range: Set fCell = ws.Range("A3")
' Blank
Dim fbCell As Range: Set fbCell = RefFirstBlankCellInColumn(fCell)
If Not fbCell Is Nothing Then
Debug.Print fbCell.Address(0, 0)
End If
End Sub