I adapted below code so that entire rows are cut and pasted at a lower location in SAME sheet based on specific value in a column. The rows are pasted not in last row, but in a few empty rows in between rows that have data. Let's say I have 12 rows that need to be copied and pasted in the 12 empty rows in between the data. The below code will first move the rows to the 12 empty rows but it will then continue to move about 6 rows that have already been moved to a location at the end of all rows. How can I have the code stop once it moves the 12 rows?
Sub MoveLS()
Dim i As Variant
Dim endrow As Integer
Dim Version3 As Worksheet
Set Version3 = ActiveWorkbook.Sheets("Version 3")
endrow = Version3.Range("A1").End(xlDown).Offset(1, 0).Row
For i = 2 To endrow
If Version3.Cells(i, "AVI").Value = "3. NOT ON LIST" Then
Version3.Cells(i, "AVI").EntireRow.Cut Destination:=Version3.Range("A1").End(xlDown).Offset(1, 0)
Version3.Cells(i, "AVI").EntireRow.Delete
End If
Next
End Sub
Here's one approach: hold off deleting the rows until you're finished with the loop.
Sub MoveLS()
Dim i As Variant
Dim endrow As Integer
Dim Version3 As Worksheet
Dim rngDel As Range
Set Version3 = ActiveWorkbook.Sheets("Version 3")
endrow = Version3.Range("A1").End(xlDown).Row 'removed the Offset(1, 0)
For i = 2 To endrow
If Version3.Cells(i, "AVI").Value = "3. NOT ON LIST" Then
Version3.Cells(i, "AVI").EntireRow.Cut _
Destination:=Version3.Range("A1").End(xlDown).Offset(1, 0)
'add a dummy value so the next xlDown doesn't stop here
Version3.Cells(i, "A").Value = "XXX"
'build range to delete later
If rngDel Is Nothing Then
Set rngDel = Version3.Cells(i, "AVI")
Else
Set rngDel = Application.Union(rngDel, Version3.Cells(i, "AVI"))
End If
End If
Next
'delete any cleared rows
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete
End Sub
Related
Hello I am wondering if anyone has any suggestions for a replacement for a Do Until loop in VBA??
My Code (see below), basically looks at cell F4, if Cell F4 is 0 then the row is selected and deleted. the cells then shift up, it loops again until the F4 is either greater than zero or it is empty.
The code actually works perfectly well but it takes an age to finish (around 3 mins at a guess). I do make sure that screen updating is turned off etc, I just haven't included that in this example.
I am not to fussed that it takes so long in the first instance but eventually it will doing this search multiple times in one hit, potentially up to 10K cells at a time so I want it to be a bit more snappy...
So my question is is there anything I can do other than Do until loops?
Do Until Raw1.Range("F4") = "" Or Raw1.Range("F4") > 0
If Raw1.Range("F4").Value = 0 Then
Raw1.Range("A4:H4").Select
Selection.Delete Shift:=xlUp
End If
Loop
Delete Data Using AutoFilter
Starting from row 4 (the header row is 3), this will delete all consecutive A:H row ranges, whose cell values in column F are equal to 0 (preserving blank cells).
Option Explicit
Sub DeleteZeros()
' 'Raw1' is the code name of a worksheet in the workbook containing this code.
Const FirstCellAddress As String = "F3"
Const ColumnsAddress As String = "A:H"
If Raw1.FilterMode Then Raw1.ShowAllData
Dim crg As Range ' Column Range (Has Headers - 'F')
With Raw1.Range(FirstCellAddress)
Dim lRow As Long
lRow = Raw1.Cells(Raw1.Rows.Count, .Column).End(xlUp).Row
Dim rCount As Long: rCount = lRow - .Row + 1
If rCount < 2 Then Exit Sub ' to few rows
Set crg = .Resize(rCount)
End With
Dim drg As Range ' Data Range (No Headers - 'A:H')
With crg
Set drg = .Resize(rCount - 1).Offset(1) _
.EntireRow.Columns(ColumnsAddress)
End With
Dim FirstDataRow As Long: FirstDataRow = drg.Row
' Filter Column Range
crg.AutoFilter 1, "0"
Dim vdrg As Range ' Visible Data Range (No Headers - 'A:H')
On Error Resume Next
Set vdrg = drg.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
Raw1.AutoFilterMode = False
' Delete
If vdrg Is Nothing Then Exit Sub
If vdrg.Cells(1).Row <> FirstDataRow Then Exit Sub
vdrg.Areas(1).Delete xlShiftUp
End Sub
It is always a better solution to delete from bottom up then from top down.
Sub deleteRows()
Const checkColumn As Long = 6 'Column F
Dim rg As Range
'!!!!!you will have to adjust this to your needs!!!!
Set rg = ActiveSheet.Cells(checkColumn, 4).CurrentRegion
Dim cntRows As Long
cntRows = rg.Rows.Count
Dim i As Long
For i = cntRows To 1 Step -1
If rg.Cells(i, checkColumn) = 0 Then
'rg.Rows(i).EntireRow.Delete xlShiftUp 'removes entire row
rg.Rows(i).Delete xlShiftUp 'removes only columns A-H
End If
Next
End Sub
It is faster to delete all the cells in 1 operation. In my example code, I have a runner find the last valid cell. I use that cell to determine the size of range that needs to be deleted.
Sub RemoveEmptyRowsBasedOnColumnValues()
Dim CalculationMode As XlCalculation
CalculationMode = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim Cell As Range
With Raw1
For Each Cell In .Range("F4", .Cells(.Rows.count, "F").End(xlUp))
If Cell.Value > 0 Then
If Cell.Row > 3 Then
.Range("A4:H4").Resize(Cell.Row - 4).Delete Shift:=xlUp
End If
Exit For
End If
Next
End With
Application.Calculation = CalculationMode
End Sub
Function Raw1() As Worksheet
Set Raw1 = ThisWorkbook.Worksheets("Raw1")
End Function
I'm trying to cut and delete some entire rows having move it in ID column and paste only the value of that ID to another sheet using a macro. What I've written so far can cut and delete the rows but paste the whole row in another sheet instead of only the IDs.
Sheet1 before running the macro:
Sheet1 after running the macro:
Sheet2 where the value should be placed like:
My following attempt can do the second step flawlessly but when it comes to paste only the value of kicked out IDs in another sheet, it pastes the whole row.
Sub CutAndPaste()
Dim cel As Range
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim wsAno As Worksheet: Set wsAno = ThisWorkbook.Sheets("Sheet2")
For Each cel In Range("C2:C10")
If cel(1, 1) = "move it" Then
ws.Range(cel(1, 1).Address).EntireRow.Cut wsAno.Range("A" & wsAno.Rows.count).End(xlUp).Offset(1, 0)
ws.Range(cel(1, 1).Address).EntireRow.Delete
wsAno.Range("B" & wsAno.Rows.count).End(xlUp).Offset(1, 0).Value = "done"
End If
Next cel
End Sub
How can I cut and delete an entire row but paste only the value of a row falling under ID column in another sheet?
Please, try the next code. It should be very fast, using an array for the ranges to be copied (cut if you like it better...) and deletion is done at once:
Sub CutAndPaste_()
Dim cel As range, rngDel As range, arrCut, lastRAn As Long, k As Long
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim wsAno As Worksheet: Set wsAno = ThisWorkbook.Sheets("Sheet2")
ReDim arrCut(1 To 2, 1 To 9) 'redim the array at a maximum able to keep all the necessary elements (10 -1)
For Each cel In ws.range("C2:C10")
If cel(1, 1).Value = "move it" Then
If rngDel Is Nothing Then 'if range to be deleted does not exist, yet:
k = k + 1
arrCut(1, k) = cel: arrCut(2, k) = "done" 'or cel.Offset(0, 1)
Set rngDel = cel
Else
k = k + 1
arrCut(1, k) = cel: arrCut(2, k) = "done" 'or cel.Offset(0, 1)
Set rngDel = Union(rngDel, cel)
End If
End If
Next cel
lastRAn = wsAno.range("A" & rows.count).End(xlUp).row + 1 'last empty row
ReDim Preserve arrCut(1 To 2, 1 To k) 'keep only the existing filled array elements
wsAno.range("A" & lastRAn).Resize(k, 2).Value = WorksheetFunction.Transpose(arrCut) 'drop the array value at once
rngDel.EntireRow.Delete xlUp 'delete the necessary rows at once
End Sub
I would suggest you to also use a variable to determine the last row in C:C and use it to create the range and also preliminary ReDim the array. It is filled with columns instead of rows, because only the last dimension can be ReDim Preserved..
For each worksheet in my workbook, I would like to:
- Check if rows contain cells with colour index -4142 (yellow)
- If yes, copy and paste row values into ToDo list.
I have tried:
1) For Each loop, as indicated below.
2) Dim i As Long
For i = 1 To ThisWorkbook.Worksheets.Count
Set Sh1 = Worksheets(i)
Sub Macro1()
Dim wrk As Workbook
Dim colCount As Integer
Dim ws As Worksheet
Dim Sh1 As Worksheet, Sh2 As Worksheet
Dim r As Range, r1 As Range, cell As Range
Dim iResponse As Integer
Dim LastRow As Long
iResponse = MsgBox("Do you want to COPY your 'Current List' (Hi-lighted rows) to the 'Select List' sheet?", vbYesNoCancel + vbQuestion + vbDefaultButton3, "Copy Selected Results To View In Select List")
Select Case iResponse
Case vbCancel
MsgBox "Cancelled", vbOKOnly + vbExclamation, "Cancelled copy"
Case vbNo: 'do Nothing
MsgBox "Doing nothing", vbOKOnly + vbInformation, "Doing nothing"
Case vbYes
For Each ws In ActiveWorkbook.Worksheets ' For each worksheet in workbook
Set Sh1 = Worksheets(ws.Index) ' Sh1 will be first, second, etc. worksheet
Set Sh2 = Worksheets("ToDo") ' sheet to copy to
Set wrk = ActiveWorkbook ' to get header as first row
colCount = Sh1.Cells(1, 255).End(xlToLeft).Column
With Sh2.Cells(1, 1).Resize(1, colCount)
.Value = Sh1.Cells(1, 1).Resize(1, colCount).Value
.Font.Bold = True
End With
Set r1 = Sh1.Range(Sh1.Cells(2, "D"), Sh1.Cells(Rows.Count, "C").End(xlUp))
For Each cell In r1
If cell.Interior.ColorIndex = 6 Then
If r Is Nothing Then
Set r = cell
Else
Set r = Union(r, cell)
End If
End If
Next
If Not r Is Nothing Then
LastRow = Sh2.Cells(Rows.Count, "C").End(xlUp).Row
With Sh2
r.EntireRow.Copy Destination:=.Range("A" & LastRow + 1)
.UsedRange.Offset(1).Interior.ColorIndex = -4142
Range("A1").Select
End With
Else
MsgBox "No info obtained", vbExclamation, "Nothing copied."
End If
Exit For ' Exit For loop
Next ws ' Next worksheet
End Select
End Sub
The expected output is:
If Sheet 1 has 3 rows - row 1: yellow, row 2: green, row 3: yellow
and Sheet 2 has 2 rows - row 1: yellow, row 2: blue
then ToDo sheet will show the values of Sheet 1 row 1, Sheet 1 row 3, Sheet 2 row 2
Currently the output is "No info obtained" msg.
This runs through each cell in the usedrange of each worksheet. If the interior color matches it copies all the values from that row, and puts it in the ToDo list worksheet. If the row counter for the todo list hasn't changed after the loops were complete then "no info obtained" message will pop up.
Option Explicit
Sub Test()
Dim oToDo As Worksheet
Set oToDo = Worksheets("ToDo")
Dim oToDoRow As Long
oToDoRow = 2 ' Whatever row your "todo" data starts on
Dim oCell As Range
Dim oCurWS As Worksheet
Dim oPrevRow As String
For Each oCurWS In ThisWorkbook.Worksheets
If oCurWS.Name <> "ToDo" Then
For Each oCell In oCurWS.UsedRange
' I used Interior Color you should be able to use colorindex in the same way
If oCell.Interior.Color = 65535 Then
If oPrevRow <> oCurWS.Index & "_" & oCell.Row Then
oToDo.Rows(oToDoRow).Value = oCurWS.Rows(oCell.Row).Value
oPrevRow = oCurWS.Index & "_" & oCell.Row
oToDoRow = oToDoRow + 1
End If
End If
Next
End If
Next
' Match oToDoRow with whatever is set as default at the top
If oToDoRow = 2 Then MsgBox "No info obtained"
End Sub
Update to prevent row being listed multiple times if more than one cell in a row was highlighted.
Do you need whole row to be "yellow" ? or there is allways one cell in each row ?.
I'm asking what if A1 is yellow ,B1 is blue, C1 is red, D1 is yellow you want to copy from this row only A1 and D1 to Sheet "ToDo"- into A1 and B1 or copy/paste entire row?
Have a great day
I am trying to delete duplicate values in a temporary list based on a value in a combobox. The code below loops through individual rows to check whether a value matches. It is slow.
Dim ws As Worksheet
Dim i As Long
Set ws = Sheets("TempList3")
On Error Resume Next
For i = Cells(Rows.Count, 2).End(xlUp).Row To 1 Step -1
If Cells(i, 2) <> Sheets("Sheet1").ComboBox2.Value Then
ws.Rows(i).EntireRow.Delete
End If
Next
Is there a way to evaluate the entire column's values against the combobox's value once and then delete all rows on a worksheet. Or perhaps there is a better way?
I used a looping Find function, it deletes the row where the value was found and then it searches again and deletes the next row it finds until it can no longer find the Combo value on the sheet:
Sub find_cell()
Dim find_cell As Range
Set ws = Sheets("TempList3")
stop_loop = False
Do Until stop_loop = True
Set find_cell = ws.Cells.Find(What:=Sheets("Sheet1").ComboBox2.Value, LookAt:=xlWhole)
If Not find_cell Is Nothing Then
ws.Rows(find_cell.Row).EntireRow.Delete
Else
stop_loop = True
End If
Loop
End Sub
Not knowing how many rows you are talking about, I used 10 thousand for my example codes. here are two examples, try the both and see what works best for you.
You can run through the column and unionize the range found, then delete the rows, for example.
See here for example workbook
Sub UnIonRng()
Dim FrstRng As Range
Dim UnIonRng As Range
Dim c As Range, s As String
s = Sheets("Sheet1").ComboBox2
Set FrstRng = Range("B:B").SpecialCells(xlCellTypeConstants, 23)
For Each c In FrstRng.Cells
If c = s Then
If Not UnIonRng Is Nothing Then
Set UnIonRng = Union(UnIonRng, c) 'adds to the range
'MsgBox UnionRng.Address 'remove later
Else
Set UnIonRng = c
End If
End If
Next c
UnIonRng.EntireRow.Delete
End Sub
Or you can try to filter the column B and delete the rows that way:
Sub FilterDeleteRow()
Dim ws As Worksheet
Dim LstRw As Long, Rng As Range, s As String, x
Set ws = Sheets("TempList3")
s = Sheets("Sheet1").ComboBox2
Application.ScreenUpdating = 0
With ws
LstRw = .Cells(.Rows.Count, "B").End(xlUp).Row
x = Application.WorksheetFunction.CountIf(.Range("B:B"), s)
If x > 0 Then
Columns("B:B").AutoFilter Field:=1, Criteria1:=s
Set Rng = .Range("B2:B" & LstRw).SpecialCells(xlCellTypeVisible)
Rng.EntireRow.Delete
.AutoFilterMode = 0
Else: MsgBox "Not Found"
End If
End With
End Sub
This is my first attempt at VBA, so I apologize for my ignorance. The situation is as follows: I have a spreadsheet that consists of 4 columns and 629 rows. When I am trying to do is iterate through the 4 cells in each row and check for a blank cell. If there is a row that contains a blank cell, I want to cut it from Sheet1 and paste it into the first available row in Sheet2.
(Ideally the number of columns AND the number of rows is dynamic based on each spreadsheet, but I have no idea how to iterate through rows and columns dynamically)
Sub Macro1()
'
' Macro1 Macro
' Move lines containing empty cells to sheet 2
'
' Keyboard Shortcut: Ctrl+r
'
Dim Continue As Boolean
Dim FirstRow As Long
Dim CurrentRow As Long
Dim LastRow As Long
Dim EmptySheetCount As Long
Dim Counter As Integer
'Initialize Variables
LContinue = True
FirstRow = 2
CurrentRow = FirstRow
LastRow = 629
EmptySheetCount = 1
'Sheets(Sheet1).Select
'Iterate through cells in each row until an empty one is found
While (CurrentRow <= LastRow)
For Counter = 1 To 4
If Sheet1.Cells(CurrentRow, Counter).Value = "" Then
Sheet1.Cells(CurrentRow).EntireRow.Cut Sheet2.Cells(EmptySheetCount, "A")
EmptySheetCount = EmptySheetCount + 1
Counter = 1
CurrentRow = CurrentRow + 1
GoTo BREAK
Else
Counter = Counter + 1
End If
Counter = 1
BREAK:
Next
Wend
End Sub
When I run it, I typically get an error around the Sheet1.Cells(CurrentRow, Counter).Value = "" area, so I know I'm referencing sheets incorrectly. I've tried Sheets(Sheet1), Worksheets("Sheet1") and nothing seems to be working. When I do change to Worksheets("Sheet1"), however, it runs and just freezes Excel.
I know I'm doing multiple things wrong, I just know way too little to know what.
Thanks a lot in advance. And sorry for the crap formatting.
There are a few things wrong with your code so rather than go through them individually here is a basic looping version that does what you're after.
Sub moveData()
Dim wksData As Worksheet
Dim wksDestination As Worksheet
Dim lastColumn As Integer
Dim lastRow As Integer
Dim destinationRow As Integer
Set wksData = Worksheets("Sheet1")
Set wksDestination = Worksheets("Sheet2")
destinationRow = 1
lastColumn = wksData.Range("XFD1").End(xlToLeft).Column
lastRow = wksData.Range("A1048576").End(xlUp).Row
For i = lastRow To 1 Step -1 'go 'up' the worksheet to handle 'deletes'
For j = 1 To lastColumn
If wksData.Cells(i, j).Value = "" Then 'check for a blank cell in the current row
'if there is a blank, cut the row
wksData.Activate
wksData.Range(Cells(i, 1), Cells(i, lastColumn)).Cut
wksDestination.Activate
wksDestination.Range(Cells(destinationRow, 1), Cells(destinationRow, lastColumn)).Select
ActiveSheet.Paste
'If required this code will delete the 'cut' row
wksData.Rows(i).Delete shift:=xlUp
'increment the output row
destinationRow = destinationRow + 1
Exit For 'no need to carry on with this loop as a blank was already found
End If
Next j
Next i
set wksData = Nothing
set wksDestination = Nothing
End Sub
There are other ways that will achieve the same outcome but this should give you and idea of how to use loops, sheets, ranges, etc.
The lastColumn and lastRow variables will find the the last column/row of data in the given columns/rows (i.e, in my code it finds the last column of data in row 1, and the last row of data in column A).
Also, you should get into the habit of debugging and stepping through code to identify errors and see exactly what each line is doing (this will also help you learn too).
You might find this of use.
It uses an array variable to store the values of the cells in the row to be moved. It does not use cut and paste, so only transfer the data values, and the code does not require activation of the required sheets.
The destination rows are in the same order as the rows on the original sheet.
The method used to find the last cell used in the row and column is more elegant than other answers given.
Option Explicit
Public Sub test_moveData()
Dim wksData As Worksheet
Dim wksDestination As Worksheet
Set wksData = shtSheet1 ' Use the Codename "shtSheet1" for the worksheet. ie the value of the sheet property that is displayed as "(Name)"
Set wksDestination = shtSheet2
moveData wksData, wksDestination
End Sub
Public Sub moveData(wksData As Worksheet, wksDestination As Worksheet)
Dim ilastColumn As Integer
Dim ilastRow As Integer
Dim iRow As Long
Dim iColumn As Long
Dim iDestinationRowNumber As Integer
Dim MyArray() As Variant
Dim rngRowsToDelete As Range
iDestinationRowNumber = 1
ilastColumn = wksData.Cells(1, wksData.Columns.Count).End(xlToLeft).Column
ilastRow = wksData.Cells(wksData.Rows.Count, 1).End(xlUp).Row
ReDim MyArray(1, ilastColumn)
Set rngRowsToDelete = Nothing
For iRow = 1 To ilastRow Step 1 'No need to go 'up' the worksheet to handle 'deletes'
For iColumn = 1 To ilastColumn
If wksData.Cells(iRow, iColumn).Value = "" Then 'check for a blank cell in the current row
MyArray = wksData.Range(wksData.Cells(iRow, 1), wksData.Cells(iRow, ilastColumn)).Value
wksDestination.Range(wksDestination.Cells(iDestinationRowNumber, 1),
wksDestination.Cells(iDestinationRowNumber, ilastColumn) _
).Value = MyArray
'Store the rows to be deleted
If rngRowsToDelete Is Nothing Then
Set rngRowsToDelete = wksData.Rows(iRow)
Else
Set rngRowsToDelete = Union(rngRowsToDelete, wksData.Rows(iRow))
End If
'increment the output row
iDestinationRowNumber = iDestinationRowNumber + 1
Exit For 'no need to carry on with this loop as a blank was already found
End If
Next iColumn
Next iRow
If Not rngRowsToDelete Is Nothing Then
rngRowsToDelete.EntireRow.Delete shift:=xlUp
End If
Set rngRowsToDelete = Nothing
Set wksData = Nothing
Set wksDestination = Nothing
End Sub
' enjoy