How can I modify the following to limit the selection to only start at row 2? Currently it selects every row.
Set myRng = .Range("D2", .Cells(.Rows.Count, "D").End(xlUp))
To make it work, you will have to ensure that there is data in cell D2. See this example.
Sub Sample()
Dim myRng As Range
Dim ws As Worksheet
Dim Lrow As Long
'~~> Change this to the relevant worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
'~~> Get last row which has data in Col D
Lrow = .Range("D" & .Rows.Count).End(xlUp).row
If Not Lrow < 2 Then
Set myRng = .Range("D2:D" & Lrow)
MsgBox myRng.Address
Else
MsgBox "There is no data in cell D2"
End If
End With
End Sub
Related
I would like to copy data from a sheet "Inv_Headers", Column C, from 2nd row until the last row to a sheet "Customers", Column U, from 4th row.
Private Sub Invoice_C()
Dim ws As Worksheet, ws1 As Worksheet
Dim lastrow As Long
Set ws = Worksheets("Inv_Headers")
Set ws2 = Worksheets("CUSTOMERS")
lastrow = ws.Cells(Rows.Count, 3).End(xlUp).Row ' last row in column C
ws.Range("C2:C" & lastrow).Copy
ws1.Range("U4").PasteSpecial xlPasteValues
ws1.Activate
End Sub
My code is giving me error msg '91' - Object variable or With block variable not set. But the code should work without With statement as well, shouldn't it?
Could I ask you for your advices, please?
Many thanks!
Based on check from #Absinthe, I've corrected the typo and here is the correct code:
Private Sub Invoice_C()
Dim ws As Worksheet, ws1 As Worksheet
Dim lastrow As Long
Set ws = Worksheets("Inv_Headers")
Set ws1 = Worksheets("CUSTOMERS")
lastrow = ws.Cells(Rows.Count, 3).End(xlUp).Row ' last row in column C
ws.Range("C2:C" & lastrow).Copy
ws1.Range("U4").PasteSpecial xlPasteValues
ws1.Activate
End Sub
In addition to Srpic's offering, I can remember not getting this part to work:
ws.Range("C2:C" & lastrow).Copy
you can fix it with ws.Range("C2", "C" & lastrow).Copy
If you start typing in Range() you will see that , is an acceptable separator, whereas : for an incomplete range assingment is not.
Private Sub Invoice_C()
Dim ws As Worksheet, ws1 As Worksheet
Dim lastrow As Long
Set ws = Worksheets("Inv_Headers")
Set ws1 = Worksheets("CUSTOMERS")
lastrow = ws.Cells(Rows.Count, 3).End(xlUp).Row ' last row in column C
ws.Range("C2", "C" & lastrow).Copy
ws1.Range("U4").PasteSpecial xlPasteValues
ws1.Activate
End Sub
I'm trying to make excel focus on the cell that contains what I've searched. So if the cell is out of view in my excel spreadsheet after the search the screen auto adjusts to that specific cell. Then, I need to take everything in that cell's row and have it automatically copy into a new tab within the same excel spreadsheet. But the rows copied in the second tab need to start with Column A in row #5 and continue on. Below is the code I have so far, I'm not too familiar with VBA but I've been working at it. Any help or insight would be greatly appreciated.
`Option Explicit
Sub FindWhat()
Dim sFindWhat As String
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim sh3 As Worksheet
Dim Search As Range
Dim Addr As String
Dim NextRow As Long
Dim cl As Range
Set sh1 = ThisWorkbook.Sheets("Sheet1")
Set sh2 = ThisWorkbook.Sheets("Sheet2")
Set sh3 = ThisWorkbook.Sheets("Sheet3")
'// This will be the row you start pasting data on Sheet3
NextRow = 5
For Each cl In Intersect(sh1.UsedRange, sh1.Columns("A")).Cells
'// the value we're looking for
sFindWhat = cl.Value
'// Find this value in Sheet2:
With sh2.UsedRange
Set Search = .Find(sFindWhat, LookIn:=xlValues,
SearchOrder:=xlByRows, SearchDirection:=xlNext)
If Search Is Nothing Then
'// Get out of here if the value is not found
'// Do NOT Exit the sub, we'll just proceed to next cell in column A
'Exit Sub
Else
'// Make sure next row in Sh3.Column("K") is empty
While sh3.Range("K" & NextRow).Value <> ""
NextRow = NextRow + 1
Wend
'// Paste the row in column K of sheet 3:
Search.Resize(1, 12).Copy Destination:=sh3.Range("K" & NextRow)
End If
End With
Next
End Sub
Try that:
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim sh3 As Worksheet
Dim rng As Range
Dim IdRng As Range
Dim SrcRng As Range
Dim Search As Range
Dim lRow1 As Long
Dim lRow2 As Long
Dim lRow3 As Long
Set sh1 = ThisWorkbook.Sheets("Plan1")
Set sh2 = ThisWorkbook.Sheets("Plan2")
Set sh3 = ThisWorkbook.Sheets("Plan3")
lRow1 = sh1.Range("A" & Rows.Count).End(xlUp).Row
If lRow1 < 4 Then lRow1 = 4
Set IdRng = sh1.Range("A4:A" & lRow1) 'Dynamic ID's Range
lRow2 = sh2.Range("L" & Rows.Count).End(xlUp).Row
If lRow2 < 4 Then lRow2 = 4
Set SrcRng = sh2.Range("L3:L" & lRow2) 'Dynamic sheet2 search range
For Each rng In IdRng
Set Search = SrcRng.Find(What:=rng, LookIn:=xlValues)
If Not Search Is Nothing Then
lRow3 = sh3.Range("K" & Rows.Count).End(xlUp).Row
If lRow3 < 5 Then lRow3 = 5
sh2.Range(Search.Address).EntireRow.Copy sh3.Range("K" & lRow3) 'dynamic paste range
Else
MsgBox rng & " was not found.", vbInformation, sh1.Name
End If
Next rng
Remember to change Set sh1 = ThisWorkbook.Sheets("Plan1"), Set sh2 = ThisWorkbook.Sheets("Plan2") and Set sh3 = ThisWorkbook.Sheets("Plan3") to the name of your sheets.
This code has dynamic ranges for your Id's column (sheet1), search's column (sheet2) and paste's column (sheet3), so it will identify automatically in which range the last data is.
The macro copies and pastes the values of a row X amount of times based on a cell value in M2. It pastes the exact numbers over and over. Is there a way to change it so that numbers will ascend as they are copied down?
E.g. if A2 contains "hello 3", after running the macro A3 will contain "hello 4", A4 will contain "hello 5".
Sub Sample()
Dim wsI As Worksheet, wsO As Worksheet
Dim lRow_I As Long, lRow_O As Long, i As Long, j As Long
'~~> Set your input and output sheets
Set wsI = ThisWorkbook.Sheets("Sheet1")
Set wsO = ThisWorkbook.Sheets("Sheet1")
'~~> Output row
lRow_O = wsO.Range("A" & wsO.Rows.Count).End(xlUp).Row + 1
With wsI
'~~> Get last row of input sheet
lRow_I = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Loop through the rows
For i = 2 To lRow_I
'~~> This will loop the number of time required
'~~> i.e the number present in cell M
For j = 1 To Val(Trim(.Range("M" & i).Value))
'~~> This copies
.Rows(i).Copy wsO.Rows(lRow_O)
'~~> Get the next output row
lRow_O = wsO.Range("A" & wsO.Rows.Count).End(xlUp).Row + 1
Next j
Next i
End With
End Sub
Example of how input screen and output screen should look:
Example of how output screen should look:
Actually no need for j loop if you use resize method.
Sub Sample()
Dim wsI As Worksheet, wsO As Worksheet, lCounter As Long
Dim lRow_I As Long, lRow_O As Long, i As Long
Set wsI = ThisWorkbook.Sheets("Sheet1")
Set wsO = ThisWorkbook.Sheets("Sheet2")
With wsI
lCounter = Val(Trim(.Range("M" & i).Value))
lRow_I = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow_I
lRow_O = wsO.Range("A" & wsO.Rows.Count).End(xlUp).Row + 1
.Rows(i).Copy wsO.Rows(lRow_O).Resize(lCounter)
Next i
End With
I upgrade my solution to have the "counter" incremented
Sub Sample()
Dim wsI As Worksheet, wsO As Worksheet
Dim lRow_I As Long, lRow_O As Long, i As Long, nRowsToPaste As Long
Dim rngToCopy As Range, rngToPaste As Range
'~~> Set your input and output sheets
Set wsI = ThisWorkbook.Sheets("SheetI")
Set wsO = ThisWorkbook.Sheets("SheetO") '<=== I made it different that wsI
'~~> Output row
lRow_O = wsO.Range("A" & wsO.Rows.Count).End(xlUp).row + 1
With wsI
'~~> Get last row of input sheet
lRow_I = .Range("A" & .Rows.Count).End(xlUp).row
'~~> Loop through the rows
For i = 2 To lRow_I
nRowsToPaste = val(Trim(.Range("M" & i).Value)) '<== set number of rows to be pasted
Set rngToCopy = .Range(.Cells(i, 1), .Cells(i, wsI.Columns.Count).End(xlToLeft)) '<== set range to be copied
Set rngToPaste = wsO.Rows(lRow_O).Resize(1, rngToCopy.Columns.Count) '<== set 1st row of the range to be pasted
rngToCopy.Copy rngToPaste '<== copy&paste the 1st row in wsO sheet '<== copy and paste the 1st row
Call Prefix(rngToPaste) '<== differentiate each single cell of pasted range by means of adding a different prefix. this will subsequently have autofill method work on cells with originally the same value as well
With rngToPaste
.AutoFill .Resize(nRowsToPaste + 1) ' <== fill all rows exploiting AutoFill method, which will work on every column being their 1st row different from each other
.Resize(nRowsToPaste + 1).Replace What:="%%*%%", Replacement:="", LookAt:=xlPart '<== remove prefix
End With
lRow_O = lRow_O + nRowsToPaste + 1 '<== GET the next output row
Next i
End With
End Sub
Sub Prefix(rng As Range)
Dim j As Long
With rng
For j = 1 To .Columns.Count
.Cells(1, j).Value = "%%" & j & "%%" & .Cells(1, j).Value
Next j
End With
End Sub
where it eliminates the need of the inner j-loop and simply upgrades the lRow_O
I have total email ids in COL A of Sheet 1 and bounced email ids in COL A of Sheet 2. I want to delete Sheet 1 values or entire rows based on values on Sheet 2.
I tried the following code but doesn't work.
Public Sub delete_selected_rows()
'look at sheet2, A1 through A3 for search values
For Each search_value In Worksheets("Sheet2").Range("A1:A3")
'as long as there is something to delete...
Do While Not Worksheets("Sheet1").Range("A1:A3"). _
Find(search_value.Value, lookat:=xlWhole) Is Nothing
'...delete that row
Worksheets("Sheet1").Range("A1:A3").Find(search_value.Value, _
lookat:=xlWhole).EntireRow.Delete
Loop
Next
End Sub
Any help ?
I would use this one:
Public Sub delete_selected_rows()
Dim rng1 As Range, rng2 As Range, rngToDel As Range, c As Range
Dim lastRow as Long
With Worksheets("Sheet1")
lastRow = .Cells(.Rows.Count,"A").End(xlUp).Row
Set rng1 = .Range("A1:A" & lastRow)
End With
Set rng2 = Worksheets("Sheet2").Range("A:A")
For Each c In rng1
If Not IsError(Application.Match(c.Value, rng2, 0)) Then
'if value from rng1 is found in rng2 then remember this cell for deleting
If rngToDel Is Nothing Then
Set rngToDel = c
Else
Set rngToDel = Union(rngToDel, c)
End If
End If
Next c
If Not rngToDel Is Nothing Then rngToDel.EntireRow.Delete
End Sub
Try this:
Sub Macro1()
Dim lrow As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
With ws1
lrow = .Range("A" & .Rows.Count).End(xlUp).Row
With .Range("B1:B" & lrow)
.Formula = "=IFERROR(MATCH(A1," & ws2.Name & "!A:A,0),"""")"
.Value = .Value
.AutoFilter 1, "<>"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
.AutoFilterMode = False
End With
End Sub
I have an Excel sheet with names as one column and their working hours as values in next column.
I want to copy names with values greater than 40 to new sheet without any blanks in columns. The new sheet should have both names and the working hours; any text in the values column should be ignored.
Sub CopyCells()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim j As Long, i As Long, lastrow1 As Long
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
lastrow1 = sh1.Cells(Rows.Count, "F").End(xlUp).Row
For i = 1 To lastrow1
If sh1.Cells(i, "F").Value > 20 Then
sh2.Range("A" & i).Value = sh1.Cells(i, "F").Value
End If
Next i
End Sub
I would recommend using AutoFilter to copy and paste as it is faster than looping. See the example below.
My Assumptions
Original Data is in Sheet 1 as shown the snapshot below
You want the output in Sheet 2 as shown the snapshot below
CODE
I have commented the code so that you will not have a problem understanding it.
Option Explicit
Sub Sample()
Dim wsI As Worksheet, wsO As Worksheet
Dim lRow As Long
'~~> Set the input sheet
Set wsI = Sheets("Sheet1"): Set wsO = Sheets("Sheet2")
'~~> Clear Sheet 2 for output
wsO.Cells.ClearContents
With wsI
'~~> Remove any existing filter
.AutoFilterMode = False
'~~> Find last row in Sheet1
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Filter Col B for values > 40
With .Range("A1:B" & lRow)
.AutoFilter Field:=2, Criteria1:=">40"
'~~> Copy the filtered range to Sheet2
.SpecialCells(xlCellTypeVisible).Copy wsO.Range("A1")
End With
'~~> Remove any existing filter
.AutoFilterMode = False
End With
'~~> Inform user
MsgBox "Done"
End Sub
SNAPSHOT
Try rhis
Sub CopyCells()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim j As Long, i As Long, lastrow1 As Long
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
lastrow1 = sh1.Cells(Rows.Count, "F").End(xlUp).Row
j = 1
For i = 1 To lastrow1
If Val(sh1.Cells(i, "F").Value) > 20 Then
sh2.Range("A" & j).Value = sh1.Cells(i, "F").Value
j = j + 1
End If
Next i
End Sub