Does anyone know what other command I need to use to copy the row label "Total WI Expenses" down 4 rows below?
The following code will find the "Total WI Expenses" and copy it to a range, however, I just want to find the total and copy the data to the 4 rows down. They need to be copied and pasted as values.
Sub Test()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim rw As Long, Cell As Range
For Each Cell In ActiveSheet.Range("B:B")
If Cell.Value = "Total WI Expenses" Then
Cell.EntireRow.copy
Range("A71").PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
End If
Next
End Sub
I sincerely appreciate your assistance.
Instead of running a For loop over the whole(!) column you may check first, if something is in the column, and then .Find the wanted value. If you found a result, then you may use it's row number.
Instead of Copy/Paste you may just assign the Range.Value to get the values without formatting.
This code copies the whole row's values four rows below.
Sub Test()
Dim ws As Worksheet
Dim c As Range
Set ws = ActiveSheet
If WorksheetFunction.CountA(ws.Columns(2)) > 0 Then
Set c = ws.Columns(2).Find( _
What:="Total WI Expenses", _
After:=ws.Cells(1, 2), _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext)
If Not c Is Nothing Then
ws.Rows(c.Row + 4).Value = ws.Rows(c.Row).Value
End If
Set c = Nothing
End If
Set ws = Nothing
End Sub
Related
I am very new to VBA and all coding so I'm not very good at even the basics yet.
I have a worksheet in excel with about a dozen different business' Balance Sheets. I need to copy all of the the rows in a specific range based on the Asset name in column D. The specific range I need to copy is in between "Securities" and "Derivatives."
I successfully copied all the lines of data in between the first set of "Securities" and "Derivatives" but my For Loop keeps copying the same first range when I need it to move to the next set of "Securities" and "Derivatives" Data.
I have tried and thought maybe adding a variable to my rngA might work? Any help is appreciated.
'''
Sub ChartReference2()
Dim findrow As Long
Dim findrow2 As Long
Dim rngA As Range
For Each cell In ActiveWorkbook.Worksheets("BS growth").Range("A:A")
If cell.Value = "Asset" Then
Worksheets("BS growth").Activate
findrow = Range("D:D").Find("Securities", Range("D3")).Row
findrow2 = Range("D:D").Find("Derivatives", Range("D" & findrow)).Row
Range("D" & findrow & ":D" & findrow2, Selection.End(xlToRight)).Select
Selection.Copy
End If
Next cell
End Sub
'''
Try this - comments in-line
Sub ChartReference2()
Dim ws As Worksheet, assetRow, f1 As Range, f2 As Range
Set ws = ActiveWorkbook.Worksheets("BS growth")
assetRow = Application.Match("Asset", ws.Columns("A"), 0)
If Not IsError(assetRow) Then 'matched a cell in Col A?
With ws.Columns("D")
Set f1 = .Find("Securities", lookat:=xlWhole, after:=.Cells(assetRow - 1), _
SearchDirection:=xlNext)
If Not f1 Is Nothing Then 'found the value?
Set f2 = .Find("Derivatives", lookat:=xlWhole, after:=f1, _
SearchDirection:=xlNext)
If Not f2 Is Nothing Then 'found the value?
ws.Range(f1, f2).Copy 'copy range
End If
End If
End With
End If
End Sub
I am trying to search Sheet1 column a for the string " Testing Test" (yes with the spaces beforehand) then copy all rows below the row containing this string until a blank row is found, then I want to paste this selected range into column A row 1 on Sheet2. Next I want to search for the string " CASH" (again yes with the spaces beforehand) and i want to copy just the row that includes that to be pasted 2 rows underneath the last row of the first range pasted.
Here is what I have so far, which does not work... I do not even address the second component of finding the second string because i can't get the first... please assist, not sure why this is not working:
Sub Test()
Dim StringToFind As String
Dim i As Range
Dim cell As Range
StringToFind = " Testing Test"
With Worksheets("Sheet1")
Set cell = .Rows(1).Find(What:=StringToFind, lookat:=xlWhole, _
MatchCase:=False, searchformat:=False)
If Not cell Is Nothing Then
For Each i In .Range(cell.Offset(1), .Cells(.Rows.Count, cell.Column).End(xlUp))
If IsNumeric(i.Value) Then
If i.Value > 0 Then
i.EntireRow.Copy
Sheets("sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
End If
End If
Next i
Else
End If
End With
End Sub
Your question lacks a little detail. However, the code below will point you in the right direction. If you need help to manage it, please ask.
Sub FindAndCopy()
' 221
Dim WsS As Worksheet ' Source
Dim WsT As Worksheet ' Target
Dim Caps() As String ' captions to find
Dim Fnd As Range ' found caption
Dim Tgt As Range ' Target
Dim Arr As Variant ' Value of Fnd
Dim f As Integer ' loop counter: Caps
With ThisWorkbook
Set WsS = .Worksheets("Sheet1") ' change to suit
Set WsT = .Worksheets("Sheet2") ' change to suit
End With
Caps = Split("Testing Test,CASH", ",") ' extend to suit
For f = 0 To UBound(Caps)
Set Fnd = WsS.Rows(1).Find(Caps(f), LookIn:=xlValues, LookAt:=xlPart, _
MatchCase:=False, SearchFormat:=False)
If Fnd Is Nothing Then Exit For
Set Fnd = Fnd.Offset(1)
If f = 0 Then Set Fnd = Fnd.Resize(Fnd.End(xlDown).Row - 1, 1)
Arr = Fnd.Value ' copies Values, not Formulas
With WsT
Set Tgt = .Cells(1, 1)
If f Then Set Tgt = Tgt.Offset(.Cells(.Rows.Count, 1).End(xlUp).Row + 1)
If VarType(Arr) >= vbArray Then
Tgt.Resize(UBound(Arr), UBound(Arr, 2)).Value = Arr
Else
Tgt.Value = Arr
End If
End With
Next f
End Sub
Observe that I discarded the leading spaces in your search criteria in favour of looking for a partial match in the Find function. In that way it doesn't matter how many spaces there are but it may cause confusion if there several matches. In that case you might reinstate the blanks by amending the array of Caps.
I am trying to transfer two rows of Sheet1 (randomly and based on certain criteria) into Sheet3.
The values in cells "P2" and "P5" indicate the row number to be transferred, and column "A" has row numbers.
There's no possibility that values in "P2" and "P5" could match multiple rows in column "A". They should match 1 row each, so only one row should be copied per "P2" and "P5". Yet, sometimes I see multiple rows getting copied.
Below is the code:
Sub copyrows()
Dim tfRow As Range, cell As Object
Set tfRow = Range("A1:A") 'Range which includes the values
For Each cell In tfRow
If IsEmpty(cell) Then
Exit Sub
End If
If cell.Value = Range("P2").Value Then
cell.EntireRow.Copy
Sheet3.Select 'Target sheet
ActiveSheet.Range("A65536").End(xlUp).Select
Selection.Offset(1, 0).Select
ActiveSheet.Paste
End If
Next
End Sub
Sub copyrows2()
Dim tfRow2 As Range, cell As Object
Set tfRow2 = Range("A1:A") 'Range which includes the values
For Each cell In tfRow2
If IsEmpty(cell) Then
Exit Sub
End If
If cell.Value = Range("P5").Value Then
cell.EntireRow.Copy
Sheet3.Select 'Target sheet
ActiveSheet.Range("A65536").End(xlUp).Select
Selection.Offset(1, 0).Select
ActiveSheet.Paste
End If
Next
End Sub
As #urdearboy mentioned in the commnets above, you need to add a row to your second A column range to avoid getting the error.
To merge two conditions, in your case add an Or to your If.
To run the code faster, don't Select and Activate different sheets, it takes a long time for the code to run. Instead, use a Range object, like CopyRng and every time the if criteria is ok, you add that cell to the range using the Union function.
Read HERE about the Union functionality.
More comments inside the code's notes below.
Modified Code
Option Explicit
Sub copyrows()
Dim Sht1 As Worksheet, Sht3 As Worksheet
Dim tfRow As Range, C As Range ' use Range not Object, also try not to use Cell it's close to Cells
Dim CopyRng As Range
Dim LastRow As Long
Set Sht1 = Sheet1
Set Sht3 = Sheet3
With Sht1
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row ' get last row with data in column A
Set tfRow = .Range("A1:A" & LastRow) 'Range which includes the values
For Each C In tfRow
If IsEmpty(C) Then
Exit Sub
End If
If C.Value = .Range("P2").Value Or C.Value = .Range("P5").Value Then ' use Or to combine both scenarios
If Not CopyRng Is Nothing Then
Set CopyRng = Application.Union(CopyRng, C) ' use Union to merge multiple ranges
Else
Set CopyRng = C
End If
End If
Next C
End With
' make sure there is at least one cells in your merged range
If Not CopyRng Is Nothing Then
' get last row with data in "sheet3"
LastRow = Sht3.Cells(Sht3.Rows.Count, "A").End(xlUp).Row
CopyRng.EntireRow.Copy Destination:=Sht3.Range("A" & LastRow + 1)
End If
End Sub
I need to copy data from one worksheet into another. However, I need a conditional copy operation that will skip rows based on criteria.
For example, if I start with...
Active Value
yes 1
no 2
no 3
yes 4
no 5
no 6
I only want to copy rows that are Active=yes, so I would end up with...
Value
1
4
Can someone show me how this is done with 1) a macro and 2) a formula?
Formula approach:
suppose your data are in sheet1, range A2:B7.
Then use this formula in sheet2 cell A2:
=IFERROR(INDEX(Sheet1!B:B,SMALL(IF(Sheet1!$A$2:$A$7="yes",ROW(Sheet1!$A$2:$A$7)),ROW()-ROW($A$2)+1)),"")
with array entry (CTRL+SHIFT+ENTER) and then drag it down.
VBA approach:
You can use AutoFilter:
Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rng As Range, rngToCopy As Range
Dim lastrow As Long
'change Sheet1 and Sheet2 to suit
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
With ws1
'assumung that your data stored in column A:B, Sheet1
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range("A1:B" & lastrow)
'clear all filters
.AutoFilterMode = False
With rng
'apply filter
.AutoFilter Field:=1, Criteria1:="yes"
On Error Resume Next
'get only visible rows
Set rngToCopy = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
'copy range
If Not rngToCopy Is Nothing Then rngToCopy.Copy Destination:=ws2.Range("A1")
'clear all filters
.AutoFilterMode = False
End With
Application.CutCopyMode = False
End Sub
Note, if you want to copy only Value column, change
Set rngToCopy = .SpecialCells(xlCellTypeVisible)
to
Set rngToCopy = .Offset(, 1).Resize(, .Columns.Count - 1).SpecialCells(xlCellTypeVisible)
It's easy enough with a macro. Assuming you're copying from the first sheet to the second sheet, and that your sample above is in columns A and B, you could do the following:
Public Sub ConditionalCopy()
Dim copyRng As Range
Set copyRng = Worksheets(1).Range("B2:B7")
Dim pasteRng As Range
Set pasteRng = Worksheets(2).Range("A2")
Dim i As Long
i = 0
For Each cell in copyRng.Cells
If cell.Offset(0, -1).Value2 = "yes" Then
pasteRng.Offset(i,0).Value2 = cell.Value2
i = i + 1
End If
Next cell
End Sub
Doing it with a formula presents a challenge in terms of not leaving any blank rows on the second sheet. It would be pretty trivial to just use the following in the second sheet:
=If(A2 = "yes",b2,"")
And copy that down, but you're going to end up with blank rows that you'll have to go back and delete yourself. If you have the ability to use the macro, it's straightforward enough that I would go that route rather than sinking too much effort into devising a formula. The more I think about it, the more I feel like it has to be a programmatic solution to avoid double references.
If you use seperate counters for the source and destination rows, and use cell references rather than ranges the following routine should do the trick
Public Sub copyactivevalue()
Dim i As Integer
Dim j As Integer
Dim acts As Excel.Worksheet
Dim news As Excel.Worksheet
Set acts = Excel.Worksheets("sheet1")
Set news = Excel.Worksheets("sheet2")
With acts
j = 2
For i = 2 To 7
If acts.Cells(i, 1).Value = "yes" Then
news.Cells(j, 1) = acts.Cells(i, 2).Value
j = j + 1
End If
Next
End With
Set acts = Nothing
Set news = Nothing
End Sub
Hope this helps
I am trying to delete a row if there is no data from A:J
I have found this code and been trying to edit it, but this is deleting the whole sheet's data eventually.
Any help would be greatly appreciated
Sub DeleteRows()
Dim rngBlanks As Range
Dim i As Integer
For i = 1 To 10
On Error Resume Next
Set rngBlanks = Columns(i).SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not rngBlanks Is Nothing Then
rngBlanks.EntireRow.Delete
End If
Next
End Sub
Trying to delete a row if no data in row A:J
What code is doing is individually checking the columns and not the range A:J as your title suggests. It is very much possible that your entire data is getting deleted because of this. Lets say A1 has some data but B1 doesn't. So your code will delete Row 1. What you have to do is to check if say A1:J1 is blank.
I think this is what you are trying?
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim rngBlanks As Range
Dim i As Long, lRow As Long, Ret As Long
'~~> Set this to the relevant worksheet
Set ws = ThisWorkbook.Sheets("Sheet2")
With ws
'~~> Get the last row in that sheet
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
lRow = 1
End If
'~~> Loop through the rows to find which range is blank
For i = 1 To lRow
Ret = Application.Evaluate("=COUNTA(A" & i & ":J" & i & ")")
If Ret = 0 Then
If rngBlanks Is Nothing Then
Set rngBlanks = .Rows(i)
Else
Set rngBlanks = Union(rngBlanks, .Rows(i))
End If
End If
Next i
End With
'~~~> Delete the range
If Not rngBlanks Is Nothing Then rngBlanks.Delete
End Sub
Another way would be to use Autofilter to delete those ranges
I stepped through your code with a sheet having some non-blank cells in columns A:J down to row 15. Rows 16:18 were entirely blank and D19=1. You want to delete rows that have blanks in every cell from A:J.
On the first iteration of your For..Next loop rngBlanks was not Nothing because typing
?rngBlanks.address
returned $A$1,$A$5:$A$19. A2:A4 were not blank. When you execute
Set rngBlanks = Columns(i).SpecialCells(xlCellTypeBlanks)
it looks for any blanks in column A which is not what you wanted to test. You want to test each row, probably within your ActiveSheet.UsedRange to see if columns A:J are all blank. So you need to define a variable
Dim Rw as Range
and iterate through each Rw in UsedRange
For Each Rw in ActiveSheet.UsedRange
If WorksheetFunction.CountBlank(range(cells(Rw,1),cells(Rw,10))) =0 Then
Rw.EntireRow.Delete
I could post the entire code here but what I've given should put you on the right track.