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.
Related
I have been trying to copy the first highlighted row of each new data after empty row and i have looked around to find a way which could do this but cannot find.
I can do this manually by putting name of rows to copy but code should be dynamic because rows order can be changed but there must be empty rows after new data.
Any help will be appreciated.
after copying and pasting the result would be like this.
My try
Sub copynextfirstrow()
lastRow = Sheets("Sheet1").Cells(.Rows.Count, "A").End(xlUp).Row
Sheets("Sheet1").Range("A1:A" & lastRow).Copy
Sheets("Sheet2").Range("A1").Cells.PasteSpecial
End Sub
Try the next code, please:
Sub copynextfirstrow()
Dim sh1 As Worksheet, sh2 As Worksheet, lastRow As Long, i As Long, rngCopy As Range
Set sh1 = Sheets("Sheet1")
Set sh2 = Sheets("Sheet2")
lastRow = sh1.cells(sh1.rows.count, "A").End(xlUp).row
For i = 1 To lastRow
If WorksheetFunction.CountA(sh1.rows(i)) = 0 And WorksheetFunction.CountA(sh1.rows(i + 1)) > 0 Then
If rngCopy Is Nothing Then
Set rngCopy = sh1.rows(i + 1)
Else
Set rngCopy = Union(rngCopy, sh1.rows(i + 1))
End If
ElseIf i = 1 And WorksheetFunction.CountA(sh1.rows(i)) > 0 Then
Set rngCopy = sh1.rows(i)
End If
If Not rngCopy Is Nothing Then
rngCopy.Copy
sh2.Range("A1").cells.PasteSpecial
End If
End Sub
It should be fast enough, firstly making a Union of the rows to be copied and pasting all the range at once.
I couldn't understand that an empty row is one having only a cell in A:A empty, so I created a piece of code which considers an empty row the one not having any record on all columns...
Quick example: search for blank cells and see if offset values exist:
Sub Blah()
Dim Cell As Range
Dim rng As Range
Set rng = Application.Intersect(Sheets("Sheet1").UsedRange, Sheets("Sheet1").Range("A:A")).SpecialCells(xlCellTypeBlanks)
For Each Cell In rng
If Cell.Offset(1, 0) <> "" Then Debug.Print Cell.Offset(1, 0)
Next Cell
End Sub
Please i have this issue and i am trying to achieve a solution using vba.
So cell
A1 has value John
A2-A3 blank
A4 has value Mary
A5-A9 blank
A10 has value Mike
A11-A14 blank
And A15 has value David
I wanna autofill only the blank spaces in the column A, like so:
A2-A3 the blanks will be filled with John
A5-A9 will be filled with Mary
A11-A14 with Mike.
So technically, I am auto filling the blank cells with the value from above
One version to do this is:
Sub Autofill1()
Dim ws As Worksheet
Dim lrow As Long
Dim i As Long
Set ws = Worksheets("Sheet1") 'Set your worksheet name
lrow = ws.Cells(Rows.Count, "A").End(xlUp).Row 'Find last row
For i = 1 To lrow 'Loop from 1st row to last row
If ws.Cells(i, "A").Value = "" Then 'If the cell value is blank then...
ws.Cells(i, "A").Value = ws.Cells(i - 1, "A").Value '.. copy the value from previous cell above
End If
Next i
End Sub
Another version is:
Sub Autofill2()
Dim ws As Worksheet
Dim FillRange As Range
Set ws = Worksheets("Sheet1") 'Set your worksheet name
On Error GoTo Errhand 'If range already is filled then go to error handler
For Each FillRange In Columns("A:A").SpecialCells(xlCellTypeBlanks) 'Define range in column A
If FillRange.Cells.Row <= ActiveSheet.UsedRange.Rows.Count Then 'Check if current row is smaller than last row
FillRange.Cells = ws.Range(FillRange.Address).Offset(-1, 0).Value 'Fill the empty cells with the non empty values
End If
Next FillRange
Errhand:
If Err.Number = 1004 Then MsgBox ("Column is already filled")
End Sub
It has been a long time, but if I'm not mistaken, the following should work:
Dim i As Integer, firstcell As Integer, lastcell As Integer
Dim currentValue As String
firstcell = 1
lastcell = 15
currentValue = ""
For i = firstcell To lastcell
If Cell(i,1).Value = "" Then
Cell(i,1).Value = currentValue
Else
currentValue = Cell(i,1).Value
End If
Next i
You loop through the cells and if there is nothing in them you write the last value in them. If they contain data, you update the currentValue
This solution using for each for more efficient looping.
Sub AutoFillIt()
Dim lLastRow As Long 'Last row of the target range
lLastRow = Cells(Rows.Count, "A").End(xlUp).Row 'Get number of rows
Dim rngCurrentCell As Range
Set rngCurrentCell = Range("A1") 'It will used for looping through the range
Dim rngTarget As Range
Set rngTarget = rngCurrentCell.Resize(lLastRow) 'Set the range working in
Dim vLastValue As Variant ' To store the value of the last not emplty cell
Dim v As Variant
For Each v In rngTarget 'looping through the target range
If v = "" Then 'if the cell is empty, write the last value in
rngCurrentCell.Value = vLastValue
Else 'if not empty, store the content as last value
vLastValue = v
End If
Set rngCurrentCell = rngCurrentCell.Offset(1) 'move to the next cell
Next v
End Sub
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
I have data in Sheet2 and then I want to copy it to Sheet1. So, I have to find the row in Sheet1 that have the same number of row in Sheet2:
Sheet1 and Sheet2 look like this:
How can I find the row in Sheet1 that has the same "num" column A in Sheet2 and add to cell C in Sheet1 the value of cell C in Sheet2 ?
Here is an example for row 2 "num 6" - it has to look like :
Try this - the general idea is you can use the Find method of a Range to find rows on both sheets with matching nums:
Option Explicit
Sub Test()
Dim i As Integer
Dim ws As Worksheet
Dim rng As Range
'set sheet1 traking value for i = to lookup on sheet2
Set ws = ThisWorkbook.Worksheets("Sheet1")
'loop through indexes
For i = 1 To 6
Set rng = ws.Columns("A:A").Find(What:=i)
rng.Offset(0, 3).Value = rng.Offset(0, 3) & AddToTraking(i)
Next i
End Sub
Function AddToTraking(ByVal num As Integer) As String
Dim ws As Worksheet
Dim rng As Range
Dim str As String
Set ws = ThisWorkbook.Worksheets("Sheet2")
Set rng = ws.Columns("A:A").Find(What:=num)
If Not rng Is Nothing Then
str = rng.Offset(0, 2).Value
Else
str = ""
End If
AddToTraking = str
End Function
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