I have a working code that looks for a value and copies the entire row, pasting it to the relevant sheet.
I would like to amend the code, so that it copies the entire row above the found value, rather than the row of the value.
Can anyone suggest a simple amendment to allow me to select the row above?
Sub Prod()
Sheets("BJ").Cells.Clear
Sheets("Master").Range("A1:A2").EntireRow.Copy Destination:= _
Sheets("BJ").Range("A1")
Dim MyRange, MyRange1 As Range
Sheets("Master").Select
LastRow = Sheets("Master").Range("K65536").End(xlUp).Row
Set MyRange = Sheets("Master").Range("M1:Q325" & LastRow)
For Each c In MyRange
If c.Value = "BJ" Then
If MyRange1 Is Nothing Then
Set MyRange1 = c.EntireRow
Else
Set MyRange1 = Union(MyRange1, c.EntireRow)
End If
End If
Next
If Not MyRange1 Is Nothing Then MyRange1.Copy Sheets("BJ").[a3]
End Sub
Here is one way to copy the row directly above the ActiveCell to the next open row of another worksheet:
Sub Dural()
Dim sh2 As Worksheet, N As Long
Set sh2 = Sheets("Destynation")
N = sh2.Cells(Rows.Count, "A").End(xlUp).Row + 1
If ActiveCell.Row = 1 Then
MsgBox "Nothing above"
Exit Sub
End If
ActiveCell.Offset(-1, 0).EntireRow.Copy sh2.Cells(N, 1)
End Sub
Related
Completely new to VBA. I basically copied the code below and I am repurposing it.. the code essentially selects a row based on whether a certain cell has a certain value. eg. if K5 is "yes" then select the row "K5" copy and paste into a new worksheet.
I am trying to do something slightly different. I want to select certain cells as opposed to the whole entire row - How do I do this
For example, If K5 is "yes", then select A5:D5 & K5 & I5??
Currently the below code below copys the whole "k5" row and pastes it in sheet 2 if there a "y" that appears in the cell "k5"..
Private Sub CommandButton1_Click()
'Declare variables
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim sht3 As Worksheet
Dim lastRow1 As Long, lastRow2 As Long, lastRow3 As Long
Dim Cell As Range
Dim RngToDelete As Range
Application.ScreenUpdating = False
'Set variables
Set sht1 = Sheets("To DO")
Set sht2 = Sheets("Ongoing")
Set sht3 = Sheets("Done")
'Select Entire Row
'Selection.EntireRow.Select
'Move row to destination sheet & Delete source row
lastRow1 = sht1.Range("A" & sht1.Rows.Count).End(xlUp).Row
lastRow2 = sht2.Range("A" & sht2.Rows.Count).End(xlUp).Row
lastRow3 = sht3.Range("A" & sht3.Rows.Count).End(xlUp).Row
With sht2
' loop column H untill last cell with value (not entire column)
For Each Cell In .Range("H2:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)
If Cell.Value = "Not started" Then
If RngToDelete Is Nothing Then
Set RngToDelete = Cell
Else
Set RngToDelete = Union(RngToDelete, Cell)
End If
lastRow1 = sht1.Range("A" & sht1.Rows.Count).End(xlUp).Row
' Copy>>Paste in 1-line (no need to use Select)
.Rows(Cell.Row).Copy Destination:=sht1.Rows(lastRow1 + 1)
'.Rows(Cell.Row).Delete
ElseIf Cell.Value = "Closed" Then
If RngToDelete Is Nothing Then
Set RngToDelete = Cell
Else
Set RngToDelete = Union(RngToDelete, Cell)
End If
lastRow3 = sht3.Range("A" & sht3.Rows.Count).End(xlUp).Row
' Copy>>Paste in 1-line (no need to use Select)
.Rows(Cell.Row).Copy Destination:=sht3.Rows(lastRow3 + 1)
'.Rows(Cell.Row).Delete
End If
Next Cell
End With
If Not RngToDelete Is Nothing Then RngToDelete.EntireRow.Delete
Application.CutCopyMode = 0
Application.ScreenUpdating = True
MsgBox "Update Done!"
End Sub
I tried to implement the below (ignore the actual cells being copied, the concept of multiple cells instead of the entire row is what im after - sourced from Select multiple ranges with VBA), which seems to work if I use it on its own, but im not able or sure where to implement it in the code above to do what I want it to do.
set rng = Union(.Range("A84:B" & LastRow),.Range("D84:E" & LastRow),.Range("H84:J" & LastRow))
Thanks for your time
Here's one way to do it:
Private Sub CommandButton1_Click()
Dim sht1 As Worksheet, sht2 As Worksheet, sht3 As Worksheet
Dim Cell As Range, e, rngDest As Range
Dim RngToDelete As Range, wsDest As Worksheet
Application.ScreenUpdating = False
Set sht1 = Sheets("To DO")
Set sht2 = Sheets("Ongoing")
Set sht3 = Sheets("Done")
For Each Cell In sht2.Range("H2:H" & _
sht2.Cells(sht2.Rows.Count, "H").End(xlUp).Row).Cells
Select Case Cell.Value 'check the row...
Case "Not started": Set wsDest = sht1
Case "Closed": Set wsDest = sht3
Case Else: Set wsDest = Nothing
End Select
If Not wsDest Is Nothing Then 'any row to copy?
BuildRange RngToDelete, Cell 'build up the delete range
Set rngDest = wsDest.Cells(Rows.Count, "A").End(xlUp).Offset(1)
For Each e In Array("A1:D1", "K1", "I1") 'array of cells/ranges to copy, in order
With Cell.EntireRow.Range(e) '#note Range() is *relative* to EntireRow
.Copy rngDest 'copy this cell/area
Set rngDest = rngDest.Offset(0, .Columns.Count) 'next paste destination
End With
Next e
End If
Next Cell
If Not RngToDelete Is Nothing Then RngToDelete.EntireRow.Delete
Application.CutCopyMode = 0
Application.ScreenUpdating = True
MsgBox "Update Done!"
End Sub
'utility sub for building up a range
Sub BuildRange(ByRef rngTot As Range, rngAdd As Range)
If rngTot Is Nothing Then
Set rngTot = rngAdd
Else
Set rngTot = Application.Union(rngTot, rngAdd)
End If
End Sub
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
I have this code which cuts and pastes an entire row to another sheet. When i set values as = it works, but when i set to like or contains, the loop doesnt happen. The value of the filter i'm looking for would keep changing including with a unique phrase. Eg: 1. Overlap error: 1234, 1. Overlap error:1235 etc.
Sub loopMe()
Dim sh As Worksheet, ws As Worksheet
Dim LstR As Long, rng As Range, c As Range
Set sh = Sheets("Sheet1") 'set the sheet to loop
Set ws = Sheets("Sheet2") 'set the sheet to paste
With sh 'do something with the sheet
LstR = .Cells(.Rows.Count, "BE").End(xlUp).Row 'find last row
Set rng = .Range("BE5:BE" & LstR) 'set range to loop
End With
'start the loop
For Each c In rng.Cells
'If c = "1. Overlap error:" Then
If c.Value Like "*1. Overlap error:*" Then
'If Left(c.Value, 17) = "1. Overlap error:" Then
'If InStr(1, c, "1. Overlap error:") > 0 Then
c.EntireRow.Copy ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1) 'copy row to first empty row in sheet2
c.EntireRow.Delete Shift:=xlUp
End If
Next c
End Sub
You can use a filter to find the data, move it and delete the rows.
Sub ed()
Dim sh As Worksheet, ws As Worksheet
Dim rng As Range
Set sh = Sheets("Sheet1")
Set ws = Sheets("Sheet2")
With sh
.Range("BE4").AutoFilter Field:=1, Criteria1:= _
"=*1. Overlap error:*", Operator:=xlAnd
Set rng = .Range("BE5:BE" & .Cells(.Rows.Count, "BE").End(xlUp).Row)
With ws
rng.SpecialCells(xlCellTypeVisible).EntireRow.Copy ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1)
End With
rng.EntireRow.Delete
.AutoFilterMode = False
End With
End Sub
So if you prefer your original approach,
Sub loopMe()
Dim sh As Worksheet, ws As Worksheet
Dim LstR As Long, c As Range
Set sh = Sheets("Sheet1")
Set ws = Sheets("Sheet2")
'find last row
LstR = sh.Range("BE65000").End(xlUp).Row
Dim irow
For irow = LstR To 5 Step -1
Set c = sh.Range("BE" & irow)
If c.Value Like "*1. Overlap error:*" Then
'copy row to first empty row in sheet2
c.EntireRow.Copy ws.Cells(65000, 1).End(xlUp).Offset(1, 0)
c.EntireRow.Delete Shift:=xlUp
End If
Next irow
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 still new to coding so i apologise if i dont understand everything.
I need to check each cell of D3:D5000 if they start with GUF. Then remove the GUF from it. Else dont do anything.
This is what ive been trying to use but im getting an error Do ohne Loop:
Sub RemoveGUFfromcellsstartingwithGUF()
Range("D3").Select
Selection.End(xlDown).Offset(1, 0).Select
ActiveCell = "end"
Range("B1").Select
Do Until ActiveCell = "end"
If ActiveCell = "GUF*" Then
ActiveCell.Value = Mid(Cell, 4, 999999)
End If
ActiveCell.Offset(1, 0).Select
End Sub
Thanks for any help/suggestions
Firstly, when you are looping through cells, it's best to use For each cell in cells, no need to change selection then.
Firstly, set a range in which you want it to run.
Sub RemoveGUFfromcellsstartingwithGUF()
dim first_cell as Range
dim last_cell as Range
dim rng as Range
set first_cell = ActiveSheet.Range("D1") 'first cell of your range
set last_cell = ActiveSheet.Range("D5000") 'last cell of your range
set rng = Range(first_cell, last_cell) 'range from first_cell to last_cell
For Each cell in rng.cells 'looping through cells of the range
'What you do here will be done to every cell.
if left(cell.value, 3) = "GUF" then cell.value = Mid(cell.value,4)
Next cell
End Sub
I hope this helps.
Is this what you are trying?
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long, i As Long
Set ws = Sheet1 '<~~ Change this to the relevant sheet
With ws
'~~> Find last row in Col D
lRow = .Range("D" & .Rows.Count).End(xlUp).Row
'~~> Loop through cell in Col D
For i = 3 To lRow
If .Range("D" & i).Value Like "GUF*" Then
.Range("D" & i).Value = Mid(.Range("D" & i).Value, 4)
End If
Next i
End With
End Sub