I'm trying to create a macro that selects the range of last row and last column.
E.g. I want to select 1, 2, 3, 4 from my spreadsheet and then delete the selection.
Data:
John | 10 | 10 | 10
Smith | 5 | 5 | 5
Fred | 8 | 8 | 8
1 | 2 | 3 | 4
Here is my code, it only selects the the last row on the A column. (selects 1 and deletes it). I need it to select 1 to 4 and delete the whole row.
Range("A" & Rows.Count).End(xlUp).Select
Selection.Delete Shift:=xlUp
Is this what you are trying? I have commented the code so that you will not have any problem understanding it.
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long, lCol As Long
Dim rng As Range
'~~> Set this to the relevant worksheet
Set ws = [Sheet1]
With ws
'~~> Get the last row and last column
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
'~~> Set the range
Set rng = .Range(.Cells(lRow, 1), .Cells(lRow, lCol))
With rng
Debug.Print .Address
'
'~~> What ever you want to do with the address
'
End With
End With
End Sub
BTW I am assuming that LastRow is the same for all rows and same goes for the columns. If that is not the case then you will have use .Find to find the Last Row and the Last Column. You might want to see THIS
The simplest modification (to the code in your question) is this:
Range("A" & Rows.Count).End(xlUp).Select
Selection.EntireRow.Delete
Which can be simplified to:
Range("A" & Rows.Count).End(xlUp).EntireRow.Delete
Another simple way:
ActiveSheet.Rows(ActiveSheet.UsedRange.Rows.Count+1).Select
Selection.EntireRow.Delete
or simpler:
ActiveSheet.Rows(ActiveSheet.UsedRange.Rows.Count+1).EntireRow.Delete
Related
I am stuck i don't know what code to use so i can search the same column twice for 2 different keyword and then copy data from the same row to another spreadsheet in sequence from a start cell. for details here's what i am trying to do.
Limit the search within a range of the worksheet (ex. Sheet 1 B1:N:200)
Search the 8th column (I) of the limit range Sheet1 for keyword ("Goods")
Copy the data found in the 2nd (C) and 5th column (F) of same row where instance "Goods " is found
Paste Value of Sheet 1 - column 2 to Sheet2 - Column 3 (no format values only), and Sheet 1 column 5 to Sheet 2 Column4 (with format and values) on a specific starting point (ex. Sheet 2 - B3) Next Match Result will be Sheet 2 - B4 and so on
5.Search AGAIN the 8th column of Sheet1 for keyword ("Services") starting from the top (B1:N1)
6.Copy the data found in the 2nd (C) and 5th column (F) of same row where instance "Services" is found
Paste Value of Sheet 1 - column 2 to Sheet2 - Column 3 (no format values only), and Sheet 1 column 5 to Sheet 2 Column4 (with format and values) to next row after the last PASTE from "Goods" was done. (ex last row match paste was C35 and D35 new found value should be paste in C36 a D36)
Ending Output should be all "Goods" results first then "Services" results
I hope i have conveyed what i need clearly
I am trying to work on this code that i found here but i just don't get how to insert the 2nd search loop for services., how to paste on specific cell in sheet2, how to follow the last row for services paste
Sub CopyCells
Dim lngLastRowSht1 As Long
Dim lngLastRowSht2 As Long
Dim counterSht1 As Long
Dim counterSht2 As Long
With Worksheets(1)
lngLastRowSht1 = .Cells(.Rows.Count, 8).End(xlUp).Row
lngLastRowSht2 = Worksheets(2).Cells(Worksheets(2).Rows.Count, 5).End(xlUp).Row
For counterSht1 = 1 To lngLastRowSht1
For counterSht2 = 1 To lngLastRowSht2
If Sheets(1).Range("" & (counterSht1)).Value = "Goods" Then
Sheets(2).Range("B" & (counterSht2), "D" & (counterSht2)).Value = Sheets(1).Range("C" & counterSht1, "D" & counterSht1).Value
End If
Next counterSht2
Next counterSht1
End With
End Sub
Edit1
As per request of sir Chris this is how it should look like
Answer for this Query was best solved by #CDP1802 Worked as needed.
I learned that I needed 2 counters for it to work :) and I also learned how to properly label target destination.
Thank you for this community:)
Increment the target row after each copy.
Option Explicit
Sub CopyCells()
Const ROW_START = 3
Dim wb As Workbook, ws1 As Worksheet, ws2 As Worksheet
Dim n As Long, r As Long, lastrow1 As Long, lastrow2 as Long
Dim keywords, word, t0 As Single: t0 = Timer
keywords = Array("Goods", "Services")
Set wb = ThisWorkbook
Set ws1 = wb.Sheets(1)
Set ws2 = wb.Sheets(2)
lastrow2 = ROW_START
Application.ScreenUpdating = False
With ws1
lastrow1 = .Cells(.Rows.Count, "I").End(xlUp).Row
For Each word In keywords
For r = 1 To lastrow1
If Len(.Cells(r, "I")) = 0 Then
Exit For
ElseIf .Cells(r, "I") = word Then
'Sht1 col 2 to Sht2 Col 3 (no format values only)
'Sht1 col 5 to Sht2 Col 4 (with format and values)
ws2.Cells(lastrow2, "C") = .Cells(r, "B")
ws2.Cells(lastrow2, "D") = .Cells(r, "E")
.Cells(r, "E").Copy
ws2.Cells(lastrow2, "D").PasteSpecial xlPasteFormats
lastrow2 = lastrow2 + 1
n = n + 1
End If
Next
Next
End With
Application.ScreenUpdating = True
MsgBox r - 1 & " rows scanned " & vbLf & n & " rows copied", _
vbInformation, Format(Timer - t0, "0.0 secs")
End Sub
You could make two routines: one for services and one for goods. But that code and the code above isn't very efficient.
Since Services & Goods are in the same column, try using the autofilter:
Sheets(2).UsedRange.autofilter Field:=8, Criteria1:=Array("Goods", "Services"), VisibleDropDown:=False, Operator:=xlFilterValues
Sheets(2).UsedRange.SpecialCells(xlCellTypeVisible).Copy
Sheets(1).Range("A1").PasteSpecial
Application.CutCopyMode = False
I've been struggling with this problem for a whole month...
Here is the point. I've got a sheet in excel called Amounts where there are many datas listed under 10 columns from cell A2 to cell J2. The last colum can vary day to day. There are headnames above those different datas that allows me to know the type of data.
Anyway, there are many columns where the header start with the following value Amount of (date). I want to make a code that;
Allows me to search automatically for all the columns'name that starts with the value Amount of
Copy all of the data below (from the first data until the last one). The range of datas under each column can vary from day to day.
And finally paste each of the range data copied under the column header on other sheet and in one single column (starting in cel(1,1)).
Here's how my current code looks like;
Dim cel As Range
With Sheets("Amounts")
Worksheets("Amounts").Activate
For Each cel In Range("A2", Range("A2").End(xlToRight)
If cel.Value Like "Amount in USD *" Then
cel.Offset(1).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy Worksheets("Pasted Amounts").Range("A2")
End If
Next cel
Could you please help me with this...? I feel like the answer is so obvious like the nose in the middle of my face.
Try this. I have commented the code so you should not have a problem understanding it.
Option Explicit
Sub Sample()
Dim wsInput As Worksheet
Dim wsOutput As Worksheet
Dim lRowInput As Long
Dim lRowOutput As Long
Dim lCol As Long
Dim i As Long
Dim Col As String
'~~> Set your sheets here
Set wsInput = Sheets("Amounts")
Set wsOutput = Sheets("Pasted Amounts")
With wsInput
'~~> Find last column in Row 2
lCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
'~~> Loop through columns
For i = 1 To lCol
'~~> Check for your criteria
If .Cells(2, i).Value2 Like "Amount in functional currency*" Then
'~~> Get column name
Col = Split(.Cells(, i).Address, "$")(1)
'~~> Get the last row in that column
lRowInput = .Range(Col & .Rows.Count).End(xlUp).Row
'~~> Find the next row to write to
If lRowOutput = 0 Then
lRowOutput = 2
Else
lRowOutput = wsOutput.Range("A" & wsOutput.Rows.Count).End(xlUp).Row + 1
End If
'~~> Copy the data
.Range(Col & "3:" & Col & lRowInput).Copy _
wsOutput.Range("A" & lRowOutput)
End If
Next i
End With
End Sub
Worth a read
How to avoid using Select in Excel VBA
Find Last Row in Excel
If cell in column I1-I14 is greater than cell in column J1-J14, I want to cut the entire row and paste values to the first empty row. (From row 16 and down.)
If cell i is greater than cell j, cut row and paste values to first empty row (row 16 in this example)
This code just pastes in the first row:
Sub Knapp6_Klicka()
Dim i As Long
Dim j As Long
j = 1
For i = 3 To 500
If Cells(i, 9).Value > Cells(i, 10).Value Then
Cells(i, 12).EntireRow.Cut Sheets("Blad1").Range("A" & j)
j = j + 1
End If
Next i
End Sub
I tried to combine the paste with two different solutions.
One like this, where I recorded a macro and went to the last cell, then up to the first empty cell:
Range("A1048576").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
And one solution that I found on an Excel community:
Sub compareresult()
Dim row1 As Integer
Dim row2 As Integer
row2 = 1
For row1 = 8 To 500
If sheet1.Cells(row1, 11).value > sheet1.Cells(row1, 9).value Then
sheet1.Cells(row1, 1).EntireRow.Copy Sheets(11).Cells(row2, 1)
row2 = row2 + 1
End If
Next row1
End Sub
If cell in column I1-I14 is greater than cell in column J1-J14, i want to cut entire row and paste values to the first empty row. (From row 16 and down)
Here is a method which doesn't cut and paste in a loop. Since you are not deleting the row or "cutting and inserting" the row, here is a simple approach. The below code follows a basic logic
Logic
Loop and identify the range.
If found, then copy the range in 1 go.
Finally clear the range which was copied (if copied).
Code
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim rngToCopy As Range
Dim i As Long
'~~> Change this to relevant sheet
Set ws = Sheet1
With ws
'~~> Loop and identify the range
For i = 2 To 14
If .Range("I" & i).Value2 > .Range("J" & i).Value2 Then
If rngToCopy Is Nothing Then
Set rngToCopy = .Rows(i)
Else
Set rngToCopy = Union(rngToCopy, .Rows(i))
End If
End If
Next i
'~~> If found then copy and clear
If Not rngToCopy Is Nothing Then
rngToCopy.Copy .Rows(16)
rngToCopy.Clear
End If
End With
End Sub
EDIT:
To incorporate new edits
Works perfectly! Thanks! :) I failed to fully describe my problem.. What i also need is to paste it as special (only paste the value and not the formulas). Do you got any quick solution for that? – Johl 5 hours ago
Replace
rngToCopy.Copy .Rows(16)
to
rngToCopy.Copy
DoEvents
.Rows(16).PasteSpecial Paste:=xlPasteValues
Have a try with this.
It's based on the range you gave. Skipped over row 1 since you have headers in it.
Dim i As Long, lRow As Long, ws As Worksheet
Set ws = Sheets("Blad1") 'Your sheet name
lRow = ws.Range("I" & Rows.Count).End(xlUp).Row + 1 'Finding the last row
If lRow < 16 Then lRow = 16 'The starting row you want to cut to
For i = 2 To 14 'Your range of rows to check
If ws.Range("I" & i) > ws.Range("J" & i) Then
ws.Range("I" & i).EntireRow.Cut ws.Range("A" & lRow) 'Cutting the whole row so you use column A to cut to
lRow = lRow + 1 'Move down 1 row for where to cut to
End If
Next i
Edit:
Because you only want the values to copy accross we can't use Cut and PasteSpecial xlValues so instead we will duplicate the value of the entire row to the new location, then clear the row (filling in for the cutting part). If clear is too much we can just ClearContents to remove the values in the cells instead of the formatting if that happens. Make sure to always save before running VBA code for the first time.
Dim i As Long, lRow As Long, ws As Worksheet
Set ws = Sheets("Blad1") 'Your sheet name
lRow = ws.Range("I" & Rows.Count).End(xlUp).Row + 1 'Finding the last row
If lRow < 16 Then lRow = 16 'The starting row you want to cut to
For i = 2 To 14 'Your range of rows to check
If ws.Range("I" & i) > ws.Range("J" & i) Then
ws.Range("A" & lRow).EntireRow.Value = ws.Range("I" & i).EntireRow.Value 'Copying the values over
ws.Range("I" & i).EntireRow.Clear 'Clear the row
lRow = lRow + 1 'Move down 1 row for where to cut to
End If
Next i
Your code is doomed to failure because you do not take into consideration that you are cutting the found row. Think about what that means. Your row with the In,Out is row 15 and you wish to paste to row 16. If you cut row 5 (for example) then rows 15 and 16 will become rows 14 and 15. It also means that your next row (which you think will be row 6) will actually be what was row 7 before the cut.
I'm trying to copy rows from one worksheet to another based on whether a string exists in a specific cell of each row. In the below example, I'm searching for Jordan in Column J. If that name is in this particular rows Column J, it gets moved to a different sheet (Final Sheet).
Sub Test()
Worksheets("All Data").Activate
Dim N As Long, i As Long
N = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To N
If InStr(1, Cells(i, "J"), "Jordan") > 0 Then
Worksheets("All Data").Rows(i).Copy
Worksheets("Final Sheet").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
Next i
End Sub
What I want to do is look for multiple strings. I can accomplish this by adding as many "Or" are needed like below.
If InStr(1, Cells(i, "J"), "Jordan") > 0 Or InStr(1, Cells(i, "J"), "Barkley") > 0 Then
I usually have 5+ strings i'm searching for and it becomes difficult to update the code each time. I would rather the strings I look for be located in a range of cells on some hidden sheet that I or someone can update easily. I've been tinkering with the below. Range does work if its a single cell. If its more such as A1:A5 then it breaks. Any thoughts on how I could accomplish this? Am I totally missing an elegant solution?
Sub Test()
Worksheets("All Data").Activate
Dim N As Long, i As Long
N = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To N
If InStr(1, Cells(i, "J"), Worksheets("List").Range("A1:A5")) > 0 Then
Worksheets("All Data").Rows(i).Copy
Worksheets("Final Sheet").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
Next i
End Sub
List Sheet
- | A |
1 | Jordan |
2 | Barkley |
3 | Batman |
4 | Robin |
5 | Ozzy |
Based on this previous answer, I customize it to your scenario
Remember to backup your data before running it.
Read the code's comments and adjust the variables' values to fit your needs.
Public Sub CopyData()
' Define the object variables
Dim sourceWorksheet As Worksheet
Dim targetWorksheet As Worksheet
Dim listRange As Range
Dim evalCell As Range
' Define other variables
Dim listRangeAddress As String
Dim startSourceRow As Long
Dim lastSourceRow As Long
Dim columnForLastRowSource As Long
Dim lastTargetRow As Long
Dim sourceRowCounter As Long
Dim columnForLastRowTarget As Long
Dim columnToEval As Long
''''' Adjust the folloing values ''''
' Set the lookup list range address
listRangeAddress = "B1:B5"
' Adjust the worksheets names
Set sourceWorksheet = ThisWorkbook.Worksheets("All Data")
Set targetWorksheet = ThisWorkbook.Worksheets("Final Sheet")
Set listRange = ThisWorkbook.Worksheets("List").Range(listRangeAddress)
' Set the initial row where data is going to be evaluated
startSourceRow = 1
' Set the column from which you're going to get the last row in sourceSheet
columnForLastRowSource = 1
' Set the column from which you're going to get the last row in targetSheet
columnForLastRowTarget = 1
' Set the column where you evaluate if condition is met
columnToEval = 10
'''''''Loop to copy rows that match'''''''
' Find the number of the last row in source sheet
lastSourceRow = sourceWorksheet.Cells(sourceWorksheet.Rows.Count, columnForLastRowSource).End(xlUp).Row
For sourceRowCounter = startSourceRow To lastSourceRow
For Each evalCell In listRange.Cells
' Evaluate if criteria is met in column
If InStr(sourceWorksheet.Cells(sourceRowCounter, columnToEval).Value, evalCell.Value) > 0 Then
' Get last row on target sheet (notice that this search in column A = 1)
lastTargetRow = targetWorksheet.Cells(targetWorksheet.Rows.Count, columnForLastRowTarget).End(xlUp).Row
' Copy row to target
sourceWorksheet.Rows(sourceRowCounter).Copy targetWorksheet.Rows(lastTargetRow + 1)
' If found, don't keep looking
Exit For
End If
Next evalCell
Next sourceRowCounter
End Sub
Let me know if it works and remember to mark the answer if it does.
This question already has an answer here:
Excel VBA - Delete Rows on certain conditions
(1 answer)
Closed 3 years ago.
like the highlighted cell, in sheet 2,if D contains inactive and H contains #N/A delete that entirw row.
See a sample code below. This is based on the data that you provided in your image. Note the comments:
Sub DeleteRow()
Dim rngRange As Range
Dim lastRow As Long
lastRow = ActiveSheet.Range("A1").CurrentRegion.Rows.Count 'Count the number of rows that have data
For i = lastRow To 1 Step -1 'Use this reverse loop so that it will delete the rows from the bottom up to prevent a bad job!
If Cells(i, 4).Value = "INACTIVE" And IsError(Cells(i, 8).Value) Then 'If 4th column is INACTIVE and 8th column is an error from a formula
Cells(i, 1).EntireRow.Delete ' delete the rows!
End If
Next
End Sub
You could try:
Option Explicit
Sub test()
Dim Lastrow As Long, i As Long
'Set the sheet you want to delete
With ThisWorkbook.Worksheets("Sheet2")
'Find the last row of column A
Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
'Loop from lastrow up to row 2 and delete if conditions met
For i = Lastrow To 2 Step -1
If .Range("D" & i).Value = "INACTIVE" And Application.WorksheetFunction.IsNA(.Range("H" & i).Value) Then
.Rows(i).EntireRow.Delete
End If
Next i
End With
End Sub