I would like to write a macro to copy only a range of Cells that has data and ignore cells with a value of NA
I have built a helper tool to ensure data gathered from multiple sources are placed in the correct corresponding columns, then from there I copy and paste those columns into a master worksheet. The Range these values are populated in are A3 through R and In column R is a Vlookup.
I want to write a macro so I can press a macro enabled button to copy the cells in that range and end where the Vlookup stops returning a value. So far I have been able to write it so it copies to the end of the Vlookup but it is still gathering results that include the formula in R.
Currently Written:
Sub Copy()
Dim ws As Worksheet
Set ws = Sheets("Sheet1")
ws.Range(ws.[A:R], ws.Cells(Rows.Count, "R").End(xlUp)).Copy
End Sub
One way.
Use Autofilter.
Filter out the values which are not #N/A
Copy the filtered range in one go.
Is this what you are trying?
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim rng As Range, filteredrng As Range
Dim lrow As Long
Set ws = Sheet1 '<~~ Change this to the relevant sheet
With ws
.AutoFilterMode = False
lrow = .Range("R" & .Rows.Count).End(xlUp).Row
Set rng = .Range("A3:R" & lrow)
With rng
.AutoFilter Field:=18, Criteria1:="<>#N/A"
Set filteredrng = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With
If Not filteredrng Is Nothing Then
'~~> COPY RANGE CODE HERE
End If
.AutoFilterMode = False
End With
End Sub
Related
I am trying to hide all rows which have blank cells in a certain column (Column H in the SOW tab).
This same macro (different rows but same syntax) worked on the third tab in this workbook. I checked, each row in the range is correct. Could it be that the range is too long?
Sub HideRowsInSOW_LOOP()
Dim r As Range, c As Range
Set r = Range("H27:H46,H48:H67,H69:H88,H90:H109,H111:H130,H132:H151,H153:H172,H174:H193,H195:H214,H216:H235,H237:H256,H258:H277,H279:H298,H300:H319,H321:H340,H342:H361,H369:H388,H390:H409,H411:H430,H432:H451,H453:H472,H474:H493,H495:H514,H516:H535,H537:H556,H558:H577,H579:H598,H600:H619,H621:H640,H642:H661,H663:H682,H684:H703")
Application.ScreenUpdating = False
For Each c In r
If c.Value = 0 Then
c.EntireRow.Hidden = True
Else
c.EntireRow.Hidden = False
End If
Next c
Application.ScreenUpdating = True
End Sub
When running this, I get the following error:
run-time error '1004' error message: Method 'Range' of object
'_Global' failed
I have a much longer macro which serves the same purpose successfully and am worried about it slowing down my workbook/keep hearing that loop is better anyway.
Your code may not be working for the relevant sheet as the range is not fully qualified. Set r = Range("H27:H46,.... The range is referring to the activesheet.
Here is one way using AutoFilter which will hide the blank rows in a column. This is much faster than looping in a huge dataset.
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long
Dim rngColH As Range
Dim rngToHide As Range
'~~> Chage this to the relevant sheet
Set ws = Sheet1
With ws
'~~> Remove any autofilter if any
.AutoFilterMode = False
'~~> Find last row in Col H
lRow = .Range("H" & .Rows.Count).End(xlUp).Row
'~~> Construct your range
Set rngColH = .Range("H1:H" & lRow)
'~~> Filter on blanks
With rngColH
.AutoFilter Field:=1, Criteria1:="="
'~~> These are your blank rows (i.e if there are any)
Set rngToHide = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With
.AutoFilterMode = False
'~~> Hide the rows
If Not rngToHide Is Nothing Then rngToHide.Hidden = True
End With
End Sub
Here is how it works...
Using .SpecialCells(xlCellTypeBlanks) as #Mikku suggested is also a good approach :)
I have a excel file where I have used the filter on a specific column. After that it returned me 3 visible rows. Now I want to extract a cell value from visible 3 rows on same column. How to write the vba code for that.
Note: I am using UFT, vb script for connecting excel application.
Environment.value("Path1")="C:Test\Data1\"
Environment.value("FileName")="ExcelTest.xlsx"
Set obj = CreateObject("Excel.Application")
obj.visible=True
Set obj1 = obj.Workbooks.Open(Environment("Path1")&Environment("FileName"))
Set obj2=obj1.Worksheets("RESULT")
obj2.Range("L1").Autofilter 12,"abcdef"
obj2.Range("A1").Autofilter 1,Array("Bucket",2,"Material","Flags"),7
rows=obj2.usedrange.columns(1).specialcells(12).count-1
if you want to work with visible cells only.
An example in which you filter on column A, to be adapted for you data, of course:
Sub test()
Dim ws As Worksheet
Dim i As Long, LastRow As Long
Dim r As Range, Cell As Range, Range As Range
Set ws = ThisWorkbook.Sheets("Sheet1")
Set r = ws.Range("A1")
ws.AutoFilterMode = False
With r
.AutoFilter Field:=1, Criteria1:="Yourcriteria"
LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
Set Range = ws.Range(ws.Cells(2, 1), ws.Cells(LastRow, 1))
For Each Cell In Range.SpecialCells(xlCellTypeVisible)
'whatever you need to be done
Next Cell
End With
ws.AutoFilterMode = False
End Sub
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 have a table Named "Combined" which is stored on one sheet of a work book.
On a second sheet I have the following Cell Range (in C1:F2)
Delivery | Column Ref | Column Ref | Available
Delivery ID | I | J | YES
I want to be able to use VBA to filter the table based on the values in this cell range
The Data drop column is a cell with a drop down list which uses VLOOKUP to populate the two column ref cells. These are the two columns that need to be filtered.
Column I needs to show all rows that <>"X" while column J needs to show all rows that equal the value in the available column.
I then need to be able to copy columns A,G and the column that appears in the first reference cell to cell A5 in the second sheet.
Is it possible to do this using VBA? I have been attempting to do this using IF statements, but it is very messy.
I have a piece of code I am attempting to modify from here
Sub Sample()
Dim ws As Worksheet, wsTemp As Worksheet
Dim rRange As Range, rngToCopy As Range
Dim lRow As Long
Dim lRow2 As Long
Dim lCol As Long
'Find the last non-blank cell in column A(1)
lRow2 = Cells(Rows.Count, 1).End(xlUp).Row
'~~> Change this to the relevant sheet
Set ws = ThisWorkbook.Sheets("Combined")
With ws
'~~> Set your range for autofilter
Set rRange = .Range("A1:AR" & lRow2)
'~~> Remove any filters
.AutoFilterMode = False
'~~> Filter, copy visible rows to temp sheet
With rRange
.AutoFilter Field:=9, Criteria1:="X"
'~~> This is required to get the visible range
ws.Rows("1:lRow2").EntireRow.Hidden = True
Set rngToCopy = .SpecialCells(xlCellTypeVisible).EntireRow
Set wsTemp = Sheets.Add
rngToCopy.Copy wsTemp.Range("A1")
'~~> Unhide the rows
ws.Rows("1:lRow").EntireRow.Hidden = False
End With
'~~> Remove any filters
.AutoFilterMode = False
End With
Application.DisplayAlerts = False
wsTemp.Delete
Application.DisplayAlerts = True
End Sub
But I do not know how to modify the With rRange section to meet my needs (i.e, Column I <>"X" and column J=F2
Additionally this line ws.Rows("1:lRow2").EntireRow.Hidden = True is giving me a type mismatch error
example of combined table
UPDATE
So my code now looks like this thanks to this thread
Sub AddFilter()
'
' AddFilter Macro
'
Dim rCrit1 As Range, rCrit2 As Range, rCrit3 As Range
Dim copyRange1 As Range, copyRange2 As Range, copyRange3 As Range
Dim filterRange As Range
Dim lastRow As Long
Set src = ThisWorkbook.Sheets("Combined")
Set tgt = ThisWorkbook.Sheets("Dashboard")
lastRow = src.Range("A" & src.Rows.Count).End(xlUp).Row
Set filterRange = src.Range("A1:Z" & lastRow)
Set copyRange1 = src.Range("A2:A" & lastRow)
Set copyRange2 = src.Range("G2:G" & lastRow)
Set copyRange3 = src.Range("I2:I" & lastRow)
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set rCrit1 = Worksheets("Dashboard").Range("Ref_1")
Set rCrit2 = Worksheets("Dashboard").Range("Ref_2")
Set rCrit3 = Worksheets("Dashboard").Range("Ref_3")
Sheets("Dashboard").Range("A1:C3").ClearContents
Sheets("Dashboard").Range("A1:C3").ClearFormats
Selection.AutoFilter
filterRange.AutoFilter Field:=rCrit1, Criteria1:="<>X"
filterRange.AutoFilter Field:=rCrit2, Criteria1:=rCrit_3
copyRange1.SpecialCells(xlCellTypeVisible).Copy tgt.Range("A5")
copyRange2.SpecialCells(xlCellTypeVisible).Copy tgt.Range("B5")
copyRange3.SpecialCells(xlCellTypeVisible).Copy tgt.Range("C5")
End Sub
However the filterRange.Autofilter line is not reading the rCrit_3 value correctly and so is not filtering based on this (Ref_3 is a named range which contains the YES cell in the first part of the problem).
Additionally the copyRange lines are giving me '1004' runtime error, but if I minimise the spreadsheet and run the code from the VBA window, it will run error free.
Can anyone shed some light on these issues?
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