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
Related
i have used this vba in my workbook
To copy entire row data based on given value from inputbox from active sheet to another existing sheet by given value in first inputbox of this strName = Trim(InputBox("What are you looking for?")) and second inputbox will ask to enter Sheet Name Set OutputWs = Worksheets(InputBox("Enter Sheet Name")) and third inputbox will ask to enter column name OutputWs.Cells(Rows.count, InputBox("Enter Column Name")).End(xlUp).Row and then matched given value data from that column of entire row should be copy from active sheet to another sheet given sheet name by inputbox in workbook & here it’s successfully copying
Here what the problem i have getting when i using this vba it’s copying matched data by given value from another sheets also
Here what i want this vba will copy matched data by given value from active sheet only not from another sheets & if I copy matched data by given value from another sheet i mean another active sheet to same OutputWs Sheet then first copied data should not be over written it will look for next blank cell or row to copy the data from there
And one more thing when i enter new sheet name in inputbox then i have getting this Error
Run-time error ‘9’:
Subscript out of range
On this line
Set OutputWs = Worksheets(InputBox("Enter Sheet Name"))
Sub SearchAll()
Dim ws As Worksheet, OutputWs As Worksheet
Dim rFound As Range, IsValueFound As Boolean, IsValueNotFound As Boolean
Dim strName As String
Dim count As Long, LastRow As Long
strName = Trim(InputBox("What are you looking for?"))
If strName = "" Then Exit Sub
Set OutputWs = Worksheets(InputBox("Enter Sheet Name"))
LastRow = OutputWs.Cells(Rows.count, InputBox("Enter Column Name")).End(xlUp).Row
For Each ws In Worksheets
If ws.Name <> OutputWs.Name Then
Debug.Print "Checking " & ws.Name
Set rFound = FindAll(ws.UsedRange, strName)
If Not rFound Is Nothing Then
Set rFound = rFound.EntireRow
count = rFound.Cells.count / Columns.count 'how many matched rows?
Debug.Print "Found " & count & " rows"
rFound.Copy OutputWs.Cells(LastRow + 1, 1)
LastRow = LastRow + count
IsValueFound = True
IsValueNotFound = True
End If
End If
Next ws
If IsValueFound Then
OutputWs.Select
MsgBox "Results pasted to " & "(" & OutputWs.Name & ")" & " Sheet"
Else
If IsValueNotFound Then
OutputWs = MsgBox("Sheet " & OutputWs.Name & " Not Found in WorkBook Do you want Create a New Sheet with Given Name Then Click Yes", vbQuestion + vbYesNo)
If OutputWs = vbYes Then
Worksheets.Add OutputWs.Name
End If
End If
End If
End Sub
Public Function FindAll(rng As Range, val As String) As Range
Dim rv As Range, f As Range
Dim addr As String
Set f = rng.Find(what:=val, After:=rng.Cells(rng.Cells.count), _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)
If Not f Is Nothing Then addr = f.Address()
Do Until f Is Nothing
If rv Is Nothing Then
Set rv = f
Else
Set rv = Application.Union(rv, f)
End If
Set f = rng.FindNext(After:=f)
If f.Address() = addr Then Exit Do
Loop
Set FindAll = rv
End Function
Sub addRows()
' Adds new blank lines based on user input, keeping formatting and formulas of above.
Dim numRows As Long
Dim raSource As Range
Dim bResult As Boolean
Set raSource = ActiveCell.EntireRow
numRows = InputBox("Enter number of rows to insert. Rows will be added above the highlighted row.")
On Error Resume Next
raSource.Copy
bResult = Range(raSource.Offset(1, 0), raSource.Offset(numRows,
0)).EntireRow.Insert(Shift:=xlShiftDown, CopyOrigin:=xlFormatFromLeftOrAbove)
Application.CutCopyMode = False
If Not bResult Then
MsgBox "Inserting rows failed!", vbExclamation
End If
End Sub
The code works how I want it to except it keeps all the data from the selected row and pastes it to new rows. I want to only keep the formatting and formulas of the selected row and insert the new row below.
Try this code. I have linkedan example workbook as well. Let me know if this works.
Download example workbook here
Sub insertXRows()
Dim cell As Range
Dim lngRows As Long
Application.ScreenUpdating = False
'ERROR HANDLER
On Error GoTo ErrMsg
'#CHECK IF ACTIVE CELL IS IN A TABLE
'SOURCE: https://stackoverflow.com/a/34077874/10807836
Dim r As Range
Dim lo As ListObject
Set r = ActiveCell
Set lo = r.ListObject
If Not lo Is Nothing Then
Select Case lo.Name
Case "Table1"
If r.Row = lo.Range.Row Then
MsgBox "In Table1 Header"
Else
MsgBox "In Table1 Body"
End If
Case "SomeOtherTable"
'...
End Select
Else
MsgBox "Active cell is not in any table. Please select a cell in an active table and retry."
Exit Sub
End If
'MSGBOX to enter #rows to insert
lngRows = InputBox("Enter number of rows to insert. Rows will be added above the highlighted row.")
'CODE TO INSERT X Rows
Selection.Resize(lngRows).EntireRow.Insert
For Each cell In Intersect(ActiveSheet.UsedRange, Selection.Offset(-1, 0).EntireRow)
If cell.HasFormula Then
cell.Copy cell.Offset(1, 0)
End If
Next
Application.ScreenUpdating = True
'ERROR MSG
On Error GoTo 0
Exit Sub
ErrMsg: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure insertX, line " & Erl & "."
End Sub
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!
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'm creating an excel file with column A to H are mandatory cells.
This excel file will be passing around for input.
So, I would like to highlight the empty cells as a reminder.
I have written the following code...
Sub Highlight_Cell()
Dim Rng As Range
For Each Rng In Range("A2:H20")
If Rng.Value = "" Then
Rng.Interior.ColorIndex = 6 ‘yellow
Else
Rng.Interior.ColorIndex = 0 'blank
End If
Next Rng
MsgBox "Please fill in all mandatory fields highlighted in yellow."
End Sub
However, I would like to set the range from A2 to the last row that contains data within column A to H.
Also, display the message box only when empty cell exist.
Could you please advise how should I amend?
Million Thanks!!!
This is a VBA solution that prevents the user from saving until the desired range is filled (acknowledging Gserg's comment that that the last row is one that has at least one cell entered)
In the second portion you can either add your sheet index directly, Set ws = Sheets(x) for position x, or Set ws = Sheets("YourSheet") for a specific sheet name
The code will only highlight truly blank cells within A to H of this sheet till the last entered cell (using SpecialCells as a shortcut). Any such cells will be selected by the code on exit
Put this code in the ThisWorkbook module (so it fires whenever the user tries to close the file)
Private Sub Workbook_BeforeClose(Cancel As Boolean)
bCheck = False
Call CheckCode
If bCheck Then Cancel = True
End Sub
Put this code in a standard module
Public bCheck As Boolean
Sub CheckCode()
Dim ws As Worksheet
Dim rng1 As Range
Dim rng2 As Range
bCheck = False
'works on sheet 1, change as needed
Set ws = Sheets(1)
Set rng1 = ws.Columns("A:H").Find("*", ws.[a1], xlValues, xlWhole, xlByRows)
If rng1 Is Nothing Then
MsgBox "No Cells in columns A:H on " & ws.Name & " file will now close", vbCritical
Exit Sub
End If
Set rng2 = ws.Range(ws.[a1], ws.Cells(rng1.Row, "H"))
On Error Resume Next
Set rng2 = rng2.SpecialCells(xlBlanks)
On Error GoTo 0
If rng2 Is Nothing Then Exit Sub
bCheck = True
rng2.Interior.Color = vbYellow
MsgBox "Please fill in all mandatory fields on " & ws.Name & " highlighted in yellow", vbCritical, "Save Cancelled!"
Application.Goto rng2.Cells(1)
End Sub