I have the following code and i want to make sure that the last row after copying a row n times highlights/selects the nth row.
Example: i copied 11 rows i want to highlight/select the 11th row instead of the whole range copied
Sub test2()
Dim n As Integer, rng As Range
'new section >>
On Error GoTo EH
Set rng = Application.InputBox("Select any cell/cells within range to copy", Type:=8)
'<<---
rng.Select
line2:
n = InputBox("type no. of times you want to be repeated minus 1 for e.g if you wnat to be repeated 3 times type 2")
Range(rng.Offset(1, 0), rng.Offset(n, 0)).EntireRow.Insert
Range(rng, rng.End(xlToRight)).Copy
Range(rng, rng.Offset(n, 0)).PasteSpecial
'this section is not necessary>>
'Set rng = rng.Offset(n + 1, 0)
'If rng = "" Then
'GoTo line1
'Else
'GoTo line2
'End If
line1:
Application.CutCopyMode = False
'range("a1").Select 'i don't think you need it
MsgBox "macro over"
'Stop is not neede
Exit Sub
EH:
MsgBox "Sub interrupted"
End Sub
Thanks
Added a message and a line that select the last copied cell
rng.Offset(n, 0).Select
MsgBox "selected the last row" & rng.Offset(n, 0).Address
Try the below
Sub test2()
Dim n As Integer, rng As Range
On Error GoTo EH
Set rng = Application.InputBox("Select any cell/cells within range to copy", Type:=8)
rng.Activate
line2:
n = InputBox("type no. of times you want to be repeated minus 1 for e.g if you wnat to be repeated 3 times type 2")
Range(rng.Offset(1, 0), rng.Offset(n, 0)).EntireRow.Insert
Range(rng, rng.End(xlToRight)).Copy
Range(rng, rng.Offset(n, 0)).PasteSpecial
rng.Offset(n, 0).Select
MsgBox "selected the last row" & rng.Offset(n, 0).Address
line1:
Application.CutCopyMode = False
Exit Sub
EH:
MsgBox "Sub interrupted"
End Sub
Related
just starting out with VBA and got stuck on this issue;
I have a resource sheet for people/equipment. The available equipment rows are lower in the sheet than the main work plan. I want to be able to select an item of equipment from the work plan and return it to the available equipment rows. The code below is what I have so far but it's not working. Not sure if it's because I have asked it to select activecell for 2 ranges?
Rng1 is the cell I want to move.
Rng2 is in the same column as Rng1 but lower down (I am trying to reference Rng1 with the same value in Column A to select the correct row).
Hope that all makes sense :)
Public Sub Return_Equipment()
Dim Name1 As String, Name2 As String, NameTemp As String, NameRef As String, Rng1 As Range, Rng2 As Range, Rng3 As Range, StatusVar As Boolean
If IsEmpty(ActiveCell) Then
MsgBox "Please select an item of equipment", vbOKOnly + vbInformation, "Selection Error"
Exit Sub
End If
On Error GoTo errorhandler
Set Rng1 = ActiveCell
Do
NameRef = Intersect(ActiveCell.EntireRow, ActiveCell.CurrentRegion.Columns(1)).Value
If (ActiveCell.Value = NameRef) = False Then
ActiveCell.Offset(1, 0).Select
End If
Loop Until (ActiveCell.Value = NameRef) = True
ActiveCell
Set Rng2 = ActiveCell
Set Rng3 = Application.InputBox("Please select last date for returning", Type:=8)
On Error GoTo 0
StatusVar = False
If IsEmpty(Rng2) Then
StatusVar = True
If WorksheetFunction.CountA(Range(Rng2.Address).Resize(, Range(Rng1.Address & ":" & Rng3.Address).Columns.Count)) <> 0 Then
MsgBox "Not all cells are empty in the destination row! Please start again.", vbCritical + vbOKOnly, "Cell Allocation Error"
Exit Sub
End If
End If
'...
'errorhandler:
'...
End Sub
I'll elaborate a little more regarding what I'm trying to do;
In the picture below I want to return the trailer "Trailer 37U52 L4386 (for trk Ranger)" from cells IV:114 & IW:114 to IV:261 & IW:262 and clear data from IV:114 & IW:114.
I start by selecting IV:114 and running the code. The code sets IV:114 to Rng1. Then it looks at Column A for the corresponding value (in this case A:261) and sets Rng2 as the cell in that row in the Rng1 column (IV:261). The end date is selected using the input box and sets Rng3 as the last column I want this change to be applied to (in the same row as Rng1) In this case I select a cell in column IW.
It is then supposed to relabel cells IV:261 & IW:261 with the values from IV:114 & IW:114 and clear data from IV:114 & IW:114. What I see it doing when I run the code is setting IV:114 & IW:114 to "Temp Value" and then relabeling it back to "Trailer 37U52 L4386 (for trk Ranger)"
Does that help anyone to see what is wrong with my code?
Picture of scenario
According to your description, that one should work.
It is not the cleanest version (you should mention worksheet...)
Public Sub Return_Equipment()
Dim Name1, Name2, NameRef As String
Dim Rng1, Rng2, Rng3 As Range
Dim i, j as Long
If IsEmpty(ActiveCell) Then
MsgBox "Please select an item of equipment", vbOKOnly + vbInformation, _
"Selection Error"
Exit Sub
End If
On Error GoTo errorhandler
Set Rng1 = ActiveCell
Set Rng2 = Cells(1, 1)
j = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row - Rng1.Row
For i = 1 to j
If Rng1.Value = Cells(Rng1.Row + i, 1).Value Then
Set Rng2 = Cells(Rng1.Row + i, 1)
End If
Next
If Rng2 = Cells(1, 1) Then
MsgBox "There is no match"
Exit Sub
End if
Set Rng3 = Application.InputBox("Please select last date for returning", Type:=8)
For i=0 to abs(Rng1.Column - Rng3.Column)
If Rng2.Offset(0, Rng1.Column + i).Value <> "" Then
NameRef = "Fail"
MsgBox "Not all cells are empty in the destination row! _
Please start again.", vbCritical + vbOKOnly, "Cell Allocation Error"
End If
Next
If NameRef <>"Fail" Then
For i=0 to abs(Rng1.Column - Rng3.Column)
Cells(Rng2.Row, Rng1.Column + i).Value = _
Cells(Rng1.Row, Rng1.Column + i).Value
Cells(Rng1.Row, Rng1.Column + i).Value = ""
Next
End If
...
error handler
...
End Sub
Just check on the index "i" that it is working properly, maybe it is one unit short or long. It is difficult to reproduce your sheet to test it.
Hope it helps!
I have a complex workbook that i need filtered using vba.
I need to delete rows that have blank cells from column G.
I then need columns C through G hidden.
Then I need Column H filtered to delete all rows greater than 2.
Finally I need Column I sorted from Largest to smallest.
This is what i have so far but It half way works and i don't want to use a command button. I want to be able to paste a document in here and the code automatically works it.
Private Sub CommandButton1_Click()
'Created by William Hinebrick 277096
Dim xRg As Range
Dim xTxt As String
On Error Resume Next
If ActiveWindow.RangeSelection.Count > 1 Then
xTxt = ActiveWindow.RangeSelection.AddressLocal
Else
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
Set xRg = Application.InputBox("Please select range:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
If (xRg.Areas.Count > 1) Or (xRg.Columns.Count > 1) Then
MsgBox "You can only select one column per time", vbInformation, "Kutools for Excel"
Exit Sub
End If
xRg.Range("A1").EntireRow.Insert
Set xRg = xRg.Range("A1").Offset(-1).Resize(xRg.Rows.Count + 1)
xRg.Range("A1") = "Temp"
xRg.AutoFilter 1, ">2"
Set xRg = Application.Intersect(xRg, xRg.SpecialCells(xlCellTypeVisible))
On Error GoTo 0
If Not xRg Is Nothing Then xRg.EntireRow.Delete
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
'Created by William Hinebrick 277096
Dim xRg As Range
Application.ScreenUpdating = False
For Each xRg In Range("G1:G10000")
If xRg.Value = "" Then
xRg.EntireRow.Hidden = True
Else
xRg.EntireRow.Hidden = False
End If
Next xRg
Application.ScreenUpdating = True
End Sub
Sub Column_Hide()
'Created by William Hinebrick 277096
Columns("C:G").EntireColumn.Hidden = True
Columns("J").EntireColumn.Hidden = True
End Sub
Private Sub Sort_Drop(ByVal Target As Range)
On Error Resume Next
Range("I1").Sort Key1:=Range("I2"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End Sub
I would like to be able to use this daily as I will be pasting New spreadsheets to this worksheet to be filtered so I may concise the results
This should do everything listed.
If you require it to perform everytime you copy data in, then the Worksheet_Changeevent from your 2nd sub is the way to go. But this means it also runs every other time you change something in your workbook. I'd personally simply assign a Keyboard shortcut to it. Seems the easiest way to go.
Option Explicit
Sub test()
Dim i As Double
Dim lastrow As Double
lastrow = ActiveSheet.UsedRange.Rows.Count
For i = lastrow To 2 Step (-1) 'delete empty G cells
If ActiveSheet.Cells(i, 7).Value = "" Then Cells(i, 7).EntireRow.Delete
Next
lastrow = ActiveSheet.Cells(Rows.Count, 7).End(xlUp).Row
For i = lastrow To 2 Step (-1) 'delete H >2
If ActiveSheet.Cells(i, 8).Value > 2 Then Cells(i, 8).EntireRow.Delete
Next
Columns("C:G").EntireColumn.Hidden = True 'hide columns
Range("I1").Sort Key1:=Range("I2"), _
Order1:=xlDescending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom 'Sort by I descending order
End Sub
I would like to be able to copy any row from sheet 2 which contains any value from column a in sheet 1. Copied and pasted into sheet 3.
I found this code online but cell value is specific. I have about 80 values so individually listing them would take to long.
Sub Test()
For Each Cell In Sheets(1).Range("J:J")
If **Cell.Value = "131125"** Then
matchRow = Cell.Row
Rows(matchRow & ":" & matchRow).Select
Selection.Copy
Sheets("Sheet2").Select
ActiveSheet.Rows(matchRow).Select
ActiveSheet.Paste
Sheets("Sheet1").Select
End If
Next
End Sub
How about this:
Option Explicit
Sub CopyThings()
Dim rng As Range
Dim rng1 As Range
Dim ans As Integer
On Error GoTo ISAIDRANGE
Set rng = Application.InputBox("what do you want to copy?", "Select Range", Type:=8)
ans = MsgBox("the whole row?", vbYesNo)
Set rng1 = Application.InputBox("where do you want to paste", "Select Range", Type:=8)
Application.ScreenUpdating = False
rng1.Parent.Activate
Select Case ans
Case Is = vbYes
rng.Rows.EntireRow.Copy rng1.Rows.EntireRow
Case Is = vbNo
rng.Copy rng1
End Select
ISAIDRANGE:
Application.ScreenUpdating = True
If Err.Number = 424 Then ans = MsgBox("that's not a valid range", vbExclamation, "I meant a VALID range")
End Sub
This code copies a block of excel data (Col A to Col BH), and prompts the user to select the row where the copied template needs to be pasted. The code seems to work just fine( feel free to clean up/optimize any code), my issue is whenever a user clicks cancel when they need to pick the row I get an error "run time error 13 type mismatch". Is there anyway to just end the macro if cancel is selected?
Sub CopyTemplate()
Worksheets("HR-Calc").Activate
Dim rng As Variant
Dim trng As Range
Dim tco As String
Dim hi As String
Dim de As String
'Use the InputBox select row to insert copied cells
Set rng = Application.InputBox("select row to paste into", "Insert template location", Default:=ActiveCell.Address, Type:=8)
startrow = rng.Row
' MsgBox "row =" & startrow
Range("Bm2") = startrow
Application.ScreenUpdating = False
'copy template block
Range("C6").End(xlDown).Select
Range("bm1") = ActiveCell.Offset(1, 0).Row
Worksheets("HR-CAlc").Activate
tco = "A6:bh" & Range("bm1")
Range(tco).Select
Selection.Copy
Range("A" & Range("bm2")).Activate
Selection.Insert Shift:=xlDown
Range("c100000").End(xlUp).Select
Selection.End(xlUp).Select
'mycell.Select
''Use the InputBox to select text to be replaced
''Set rep = Application.InputBox("select data range where text will be replaced", Default:=ActiveCell.Address, Type:=8)
'Set rep = ActiveCell
' Told = Application.InputBox("Find the text that needs to be replaced", "Find text in Input data", Default:=ActiveCell.Value, Type:=2)
' If Told = "" Or vbCancel Then
' End If
'
' Tnew = Application.InputBox("Input desired text", "Replace text in data", Default:=ActiveCell.Value, Type:=2)
' If Tnew = "" Or vbCancel Then
' End If
'
' rep.Select
' Selection.Replace What:=Told, Replacement:=Tnew, LookAt:=xlPart, _
' SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
' ReplaceFormat:=False
Range("bm1:bm2").ClearContents
SendKeys "{F2}"
SendKeys "{BS}"
Application.ScreenUpdating = True
End Sub
You still need error handling to detect the Cancel
Dim rng As Range '<~~~ change type so If test will work
'Use the InputBox select row to insert copied cells
Set rng = Nothing ' in case it was previously set
On Error Resume Next
Set rng = Application.InputBox("select row to paste into", "Insert template location", Default:=ActiveCell.Address, Type:=8)
On Error GoTo 0 ' or your error handler
If rng Is Nothing Then
' User canceled, what now?
Exit Sub 'maybe...
End If
Add these lines including error handler:
On Error Resume Next
Set rng = Application.InputBox("select row to paste into", "Insert template location", Default:=ActiveCell.Address, Type:=8)
On Error GoTo 0
If IsEmpty(rng) = True Then
Exit Sub
End If
These lines will exit the sub if it won't find any value for rng.
I have the following macro made by someone else :
Sub test2()
Dim n As Integer, rng As Range
'n = InputBox("type the value of n")
Set rng = Range("a1")
rng.Select
line2:
n = InputBox("type no. of times you want to be repeated minus 1 for e.g if you wnat to be repeated 3 times type 2")
Range(rng.Offset(1, 0), rng.Offset(n, 0)).EntireRow.Insert
Range(rng, rng.End(xlToRight)).Copy
Range(rng, rng.Offset(n, 0)).PasteSpecial
Set rng = rng.Offset(n + 1, 0)
If rng = "" Then
GoTo line1
Else
GoTo line2
End If
line1:
Application.CutCopyMode = False
Range("a1").Select
MsgBox "macro over"
Stop
End Sub
I want the range selection to be dynamic i.e in the above code its hard coded to "a1" but since i want to repeat the macro again and again i want to select different starting point every time by selecting it through my mouse click.
Also when i am done with copying the cells its restarts, and i want to stop the macro once i have copied it one time . then select the new starting point select a row and then copy it x # of times
Thanks for your help in advance
The code you presented has some strange logic. Trying to change it according to your needs I changed a bit more then you asked for. I hope this is what you need, now. See some comments inside the sub, too.
Sub test2()
Dim n As Integer, rng As Range
'new section >>
On Error GoTo EH
Set rng = Application.InputBox("Select any cell/cells within range to copy", Type:=8)
'<<---
rng.Select
line2:
n = InputBox("type no. of times you want to be repeated minus 1 for e.g if you wnat to be repeated 3 times type 2")
Range(rng.Offset(1, 0), rng.Offset(n, 0)).EntireRow.Insert
Range(rng, rng.End(xlToRight)).Copy
Range(rng, rng.Offset(n, 0)).PasteSpecial
'Selection code:
Rng.offset(n,0).select
'this section is not necessary>>
'Set rng = rng.Offset(n + 1, 0)
'If rng = "" Then
'GoTo line1
'Else
'GoTo line2
'End If
line1:
Application.CutCopyMode = False
'range("a1").Select 'i don't think you need it
MsgBox "macro over"
'Stop is not neede
Exit Sub
EH:
MsgBox "Sub interrupted"
End Sub