i have MyRange = A1:C3
current values in the range are as below:
A1=a, B1=d, C1=f
A2=b, B2=e, C2=""
A3=c, B3="", C3=""
the blank cells in the range can vary.
how can i copy (using vba) non-blank values from MyRange and paste them all together let's say to column AA?
Eg:
AA1=a
AA2=b
AA3=c
AA4=d
AA5=e
AA6=f
Thanks again guys :-)
Paul
Iterate through all cells in MyRange, if cell is not "" copy value to next target cell
Sub test()
Dim MyRange as Range
Dim TargetCell as Range
Dim rw as Range
Dime cl as Range
Set MyRange = ActiveWorkbook.Names("MyRange").RefersToRange
Set TargetCell = Range("AA1")
For each rw in MyRange.Columns
For each cl in rw.Cells
If cl.value <> "" then
TargetCell = cl.value
Set TargetCell = TargetCell.Offset(1,0)
End If
Next
Next
End Sub
Related
I want to do that; i1=A2.value i2=A3.value i3=A4.value ..... but ı dont know how to start it.
Public Sub SetVariable()
Dim cell As Range
Dim rng As Range
Dim i As Integer
Set rng = Range("B2", Range("B1").End(xlDown))
For Each cell In rng
For i = 1 To rng
i = Range("A" & cell.Row)
Next i
Next cell
End Sub
I would like to have a macro that deletes an entire row of the cell value equals "" for multiple ranges. Ranges are "B16:B115, B131:B230, B250:B349".
Logic:
If cell equals "" then delete the entire row.
I want the row actually deleted and not just the contents of the cells.
Thank you.
This would be worth trying:
On Error Resume Next
Range("B16:B115,B131:B230,B250:B349").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error Goto 0
Depending on whether the "" cells have formulas or are just empty.
Range.SpecialCells: What does xlCellTypeBlanks actually represent?
EDIT: if you have formulas then you have to go the long way round:
Sub DeleteEmpty()
Dim c As Range, rngDel As Range
For Each c In Range("B16:B115,B131:B230,B250:B349").Cells
If Len(c.Value) = 0 Then
If rngDel Is Nothing Then
Set rngDel = c
Else
Set rngDel = Application.Union(rngDel, c)
End If
End If
Next c
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete
End Sub
Following sub will allow you to select range to delete blank rows.
Sub RemoveBlanks()
Dim rng As Range, rws As Long, i As Long
Dim LastRow As Range
Dim myRange As Range
Set myRange = Application.InputBox(prompt:="Select Header Cell To Remove Blanks.", Type:=8)
'LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Set LastRow = Cells(Rows.Count, myRange.Column).End(xlUp)
Set rng = ActiveSheet.Range(myRange.Address & ":" & LastRow.Address)
rws = rng.Rows.Count
For i = rws To 1 Step (-1)
If WorksheetFunction.CountA(rng.Rows(i)) = 0 Then rng.Rows(i).EntireRow.Delete
Next
Set myRange = Nothing
Set LastRow = Nothing
Set rng = Nothing
End Sub
I am working on excel sheet, in a column having multiple dates and other numbers. I trying to select the date only and copy it to next column. I tried to use Find and replace option but its not working, i used the script of KUTOOLS, but its selecting the range of values. So value falls in the same range of two different values, so could not differentiate. How to select the cells only date in Excel.
Sub FindReplace()
'Update 20150423
Dim Rng As Range
Dim WorkRng As Range
On Error Resume Next
xTitleId = "KutoolsforExcel"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
For Each Rng In WorkRng
If Rng.Value > 500 Then
Rng.Value = 0
End If
Next
End Sub
Below is the excel sheet
You could try:
Option Explicit
Sub test()
Dim LastRow As Long, i As Long
With ThisWorkbook.Worksheets("Sheet1") '<- Refer to the sheet you want
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row '<- Find the last row of column A
For i = 2 To LastRow '<- Loop from row 2 to last row
If IsDate(.Range("A" & i).Value) Then '<- Check if column A row i is date
'Code Here
End If
Next i
End With
End Sub
You can use the IsDate function on cell.Value (not Value2) to filter if the value is in DATE format.
Dim rng As Range
Set rng = Worksheets(1).Range("A2", "A5")
Dim cell As Range
For Each cell In rng.Cells
With cell
If IsDate(cell.Value) Then
Debug.Print cell.Value
End If
End With
Next cell
Sub NSV_LINK()
Dim cell As Range
Dim Rng As Range
Set Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
For Each cell In Rng
If cell.Value = "Hemanta" Then cell.EntireRow.Copy Sheets(2).Cells(1, 1)
Next cell
End Sub
In the code above, I want the macro to copy and paste values in successive rows in sheet 2. However, I have hard coded the destination cell i.e, the value gets pasted at A1. How do I write the cell destination, so that the values get pasted in successive rows? Cells(i, 1)...Something like this. And then i takes a range from, let's say 1 to 20. How do I write this in code?
you need a counter and you have to increment it
Sub NSV_LINK()
Dim cell As Range, Rng As Range, r As Long
Set Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
r = 1
For Each cell In Rng
If cell.Value = "Hemanta" Then
cell.EntireRow.Copy Sheets(2).Cells(r, 1)
r = r + 1
End If
Next cell
End Sub
you can adapt the same technique you already used in Set Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp)) to make destination range dynamic:
Sub NSV_LINK()
Dim cell As Range, Rng As Range
Set Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
For Each cell In Rng
If cell.Value = "Hemanta" Then cell.EntireRow.Copy Sheets(2).Cells(Rows.Count, 1).End(xlUp).Offset(1) ' make destination range dynamic to target sheeet column A first not empty cell after last not empty one
Next cell
End Sub
Hi all I have a sheet with more then 60 000 rows and I want to copy all rows to a new sheet if column of row contains certain value for example Energizer like in the following code
Sub Macro3()
Dim rngA As Range
Dim cell As Range
Set col = Cells(Rows.Count, "A").End(xlUp)
Set rngA = Range("A2", col)
For Each cell In rngA
If cell.Value = "Energizer" Then
cell.EntireRow.Copy
End If
Next cell
End Sub
Code doesn't work at all what could be done?
The following copies all rows containing "Energizer" in column A into the clipboard.
Sub Macro3()
Dim rngA As Range
Dim cell As Range
Dim col As Range
Dim copiedRange As Range
Dim r As Integer
Set col = Cells(Rows.Count, "A").End(xlUp)
r = 0
Set rngA = Range("A2", col)
For Each cell In rngA
If cell.Value = "Energizer" Then
If r = 0 Then
Set copiedRange = cell.EntireRow
r = 1
Else
Set copiedRange = Union(copiedRange, cell.EntireRow)
End If
End If
Next cell
If r = 1 Then
copiedRange.Copy
End If
End Sub
As mentioned in the code, if you want to copy the rows directly to a new sheet, add the destination after the copy command.
If this is really all of your code, you forgot to paste your copied row to the new sheet.