Copy columns based on the autofiltered column, then paste value only to that autofiltered column - excel

I want to filter column B based on values like "Unknown", then filter L column to have un-null values. copy the L column.
Paste values only to the column B.
Before:
ColumnB ..... Column L
1 ..... a
2 ..... b
Unknown.c
3.......d
Unknown.e
Unknown.
After
1 ..... a
2 ..... b
c.......c
3.......d
e.......e
Unknown..
Set r1 = Range("B:B").SpecialCells(xlCellTypeVisible)
Set r2 = Range("L:L").SpecialCells(xlCellTypeVisible)
Set myMultipleRange = Union(r1, r2)
Application.ScreenUpdating = False
sh1.Range("B:L").AutoFilter
sh1.Range("B:B").AutoFilter Field:=1, Criteria1:="Unknown", Operator:=xlFilterValues
sh1.Range("L:L").AutoFilter Field:=11, Operator:=xlFilterValues, Criteria1:="<>"
LstRw = sh1.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
If LstRw <> 0 Then
myMultipleRange.FillLeft
End If
The above code will copy and paste including the format.

Copy/paste in a filtered table is no good idea, because it inserts data continously even in hidden rows and messes up your data.
I recommend the following:
Filter data
Loop through all visible cells and copy the data row by row
If the following data is given …
… and you want to replace unkown with the data in column L, you can do the following:
Option Explicit
Public Sub FilterAndCopy()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Tabelle1")
'Filter data
ws.Range("B:B").AutoFilter Field:=1, Criteria1:="Unknown", Operator:=xlFilterValues
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
Dim DestinationRange As Range
On Error Resume Next 'next line throws error if filter returns no data rows
Set DestinationRange = ws.Range("B2", "B" & LastRow).SpecialCells(xlCellTypeVisible) 'find visible cells between B2 (exclude header) and last row in B
On Error GoTo 0 'always re-activate error reporting!
If Not DestinationRange Is Nothing Then 'do it only if there is visible data
Dim Cell As Range
For Each Cell In DestinationRange 'copy each value row wise
Cell.Value = Cell.Offset(ColumnOffset:=10).Value 'column L is 10 columns right of B
Next Cell
End If
End Sub

Alternative solution - simply go through each cell in column B and replace "Unknown" with a respective value in column L.
Sub foo()
Dim lngLastRow As Long
Dim rngCell As Range
With Sheet1
LastRow = .Range("B" & Rows.Count).End(xlUp).Row
For Each rngCell In .Range("B1:B" & LastRow)
If rngCell.Value = "Unknown" Then
rngCell.Value = .Range("L" & rngCell.Row).Value
End If
Next rngCell
End With
End Sub
P.S. Make sure to replace With Sheet1 statement with a relevant sheet name/code.

Related

Loop through only filtered visible rows

I have a problem with below code. I would like to filter "OS" (filed 61) then if first cell in 1st column below filters is not empty macro should go to first cell below filters in column "57", check if value in that cell is > 365 if yes it should go to column 62 in the same row and put there "overdue" if no then put there "OK". After that it should go to next row and check the same till the end of the filtered rows.
The problem is with visible only cells. Macro is doing it on all rows even not visible.
It should work only for filtered visible rows. Any suggestions?
Sub Patch_Overdue()
Dim i As Long
Dim LastRow As Long
Sheets("Sheet1").Select
'filter AIX OS
Selection.Autofilter Field:=61, Criteria1:="AIX*"
ActiveSheet.Autofilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(1, 61).Select
If IsEmpty(Selection) = False Then
LastRow = Range("a7").End(xlDown).Row
For i = 1 To LastRow
If ActiveSheet.Autofilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(i, 57).Value > 365 Then
ActiveSheet.Autofilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(i, 62).Select
ActiveCell.FormulaR1C1 = "Overdue"
Else
ActiveSheet.Autofilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(i, 62).Select
ActiveCell.FormulaR1C1 = "OK"
End If
Next i
Else
ActiveSheet.ShowAllData
End If
End Sub
Please, try the next code. It is not tested, but it should work. Basically, it set the range to be processed based on the last cell in A:A and UserRange number of columns, extract the visible cells range, iterate between its areas and the between each area rows and check what you need:
Sub Patch_Overdue()
Dim sh As Worksheet, rngUR As Range, rngVis As Range, i As Long, LastRow As Long
Set sh = Sheets("Sheet1")
If sh.AutoFilterMode Then sh.AutoFilterMode = False 'eliminate a previous filter to correctly calculate last row
LastRow = sh.Range("A" & sh.rows.count).End(xlUp).row 'last row
'filter AIX OS
Set rngUR = sh.Range("A7", sh.cells(LastRow, sh.UsedRange.Columns.count)) 'set the range to be filtered
rngUR.AutoFilter field:=61, Criteria1:="AIX*" 'filter the range according to criteria
Set rngVis = rngUR.Offset(1).SpecialCells(xlCellTypeVisible) 'set the visible cells range
Dim arRng As Range, r As Range
For Each arRng In rngVis.Areas 'iterate between the range areas:
For Each r In arRng.rows 'iterate between the area rows:
If WorksheetFunction.CountA(r) > 0 Then 'for the case of the last row which is empty because of Offset
If r.cells(1, 57).value > 356 Then
r.cells(1, 62).value = "Overdue"
Else
r.cells(1, 62).value = "OK"
End If
End If
Next
Next
sh.ShowAllData
End Sub

Excel VBA Select every other cell and paste it into another sheet?

I need to copy data from the 8th row into another sheet(sheet 2). I only need to copy every other cell, it should copy cell C8(first cell where the value is), E8, G8, I8 and so on from all the upto cell IK8.
Is there any way to do this? I have tried the step function in the for loop but its not working and only selecting one cell.It only pastes one value for cells H2:H130.
Sub Workplace()
Dim rng As Range
Dim LastRow As Long
Dim I As Long
LastRow = Worksheets("Questions").Range("C" & Rows.Count).End(xlUp).Row
For I = 8 To LastRow Step 3
Set rng = Worksheets("Questions").Range("C" & I)
rng.Copy
Next I
Worksheets("Sheet1").Range("H2:H130").PasteSpecial Transpose:=True
End Sub
You need to increment the column, not the row.
And move the paste inside the loop, though you need to increment the destination cell.
For i = 3 to 245 Step 2 ' column C to column IK
Set rng = Worksheets("Questions").Cells(8, i)
With Worksheets("Sheet1")
Dim dest as Range
Set dest = .Range("H" & .Rows.Count).End(xlUp).Offset(1)
End With
rng.copy Destination:=dest
Next
Or better, just use Union to build up a range to copy and then copy in one step:
For i = 3 to 245 Step 2 ' column C to column IK
If rng Is Nothing Then
Set rng = Worksheets("Questions").Cells(8, i)
Else
Set rng = Union(rng, Worksheets("Questions").Cells(8, i))
End If
Next
rng.Copy
Worksheets("Sheet1").Range("H2").PasteSpecial Transpose:=True
Application.CutCopyMode = False
EDIT:
"Is there a way to paste it in the first empty cell for Row H in sheet 1 instead of giving it a range?"
Yes, like the following:
Worksheets("Sheet1").Range("H" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Transpose:=True

VBA - Highlight/Delete row if Range is Empty

I have a range of data, with CASE ID's in Column A, and Issues (1 through 10, or Columns B through K) in Columns B onwards.
Once certain issues are ruled out as 'normal', they would be removed from the Issues sheet based on their respective column. For ex: CASE ID #25, Issue 4 is ruled OK, then it would be deleted from Row 25, Column 5 (or Column E) but the CASE ID would remain.
The goal is that by doing this check after the fact, it may leave certain rows entirely blank, from Column B onwards (since the CASE ID would already be there.)
My code doesn't function successfully. Once run, it highlights several rows that are not entirely blank in the target range.
I'm trying to pinpoint rows in the range B2:P & lastrow where the entire row is blank, and then highlight these rows and subsequently delete them.
Code:
Public Sub EmptyRows()
lastrow = Sheets("Issues").Cells(Rows.Count, "A").End(xlUp).row
On Error Resume Next
Sheets("Issues").Activate
For Each rng In Range("B2:P" & lastrow).Columns
rng.SpecialCells(xlCellTypeBlanks).EntireRow.Interior.ColorIndex = 11
'rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Next rng
Application.ScreenUpdating = True
End Sub
The purpose of first highlighting is to test the code works. If successful, they would be deleted entirely.
Your description says Columns B through K, but your code has B through P...
You can do it like this (adjust resize for actual columns involved):
Public Sub EmptyRows()
Dim lastRow As Long, sht As Worksheet, c As Range, rngDel As Range
Set sht = Sheets("Issues")
For Each c In sht.Range(sht.Range("A2"), sht.Cells(Rows.Count, 1).End(xlUp)).Cells
If Application.CountA(c.Offset(0, 1).Resize(1, 10)) = 0 Then
'build range to delete
If rngDel Is Nothing Then
Set rngDel = c
Else
Set rngDel = Application.Union(rngDel, c)
End If
End If
Next c
'anything to flag/delete ?
If Not rngDel Is Nothing Then
rngDel.EntireRow.Interior.ColorIndex = 11
'rngDel.EntireRow.Delete '<< uncomment after testing
End If
End Sub
Once run, it highlights several rows that are not entirely blank in the target range.
This is because you are selecting all blanks, instead of only rows where the entire row is blank.
See the code below
Public Sub EmptyRows()
With Sheets("Issues")
lastrow = .Cells(Rows.Count, "A").End(xlUp).row
Dim rng as Range
For Each rng In .Range("B2:B" & lastrow)
Dim blankCount as Integer
blankCount = Application.WorksheetFunction.CountA(rng.Resize(1,.Range("B:P").Columns.Count))
If blankCount = .Range("B" & lastRow & ":P" & lastRow).Columns.Count Then
Dim store as Range
If store Is Nothing Then Set store = rng Else: Set store = Union(rng, store)
End If
Next rng
End With
store.EntireRow.Interior.ColorIndex = 11
'store.EntireRow.Delete
End Sub
Gathering the ranges first and then modified them (changing color or deleting) will help to execute the code faster.
Here is another approach, using CountA
For Each cell In Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row)
Dim rng As Range
Set rng = Range("A" & cell.Row & ":" & "P" & cell.Row)
If Application.WorksheetFunction.CountA(rng) = 1 Then
rng.EntireRow.Interior.ColorIndex = 11
End If
Next cell

Transferring rows into another sheet

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

Excel expression to copy rows but remove blank rows

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

Resources