Copy /past cells by inputbox on sheet 2 to sheet1 using VBA

[Jd1uth]

Hallo i am new and hope you can help.
I am trying to copy a range cells by search on sheet 2 with a inputbox then select the cells and copy them on sheet 1 by inputbox select cell/cells to copy to.
This works ok but i want to stay on sheet 1, now it going to sheet 2 and i have to go back to sheet 1 manually.
I use this code below can someone help.

Sub Find_First()
Dim FindString As String
Dim rng As Range
FindString = InputBox("Enter a Search value")
If Trim(FindString) <> "" Then
    With Sheets("Sheet2").Range("A:M") 'searches all of column A to M
        Set rng = .Find(What:=FindString, _
                        After:=.Cells(.Cells.Count), _
                        LookIn:=xlValues, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)
        If Not rng Is Nothing Then
            Application.Goto rng, False 'value found
        Else
            MsgBox "Nothing found" 'value not found
        End If
    End With
End If
ActiveCell.CurrentRegion.Select
   On Error Resume Next
    Set Ret = Application.InputBox(Prompt:="Please select a range where you want to paste", Type:=8)
    On Error GoTo 0
    If Not Ret Is Nothing Then
        Selection.Copy
        Ret.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
    End If
  
End Sub

 

[DanteAmor]

Hi and welcome

Try this:

Sub Find_First()
  Dim FindString As String
  Dim rng As Range, ret As Range
  
  FindString = InputBox("Enter a Search value")
  If Trim(FindString) <> "" Then
    With Sheets("Sheet2").Range("A:M") 'searches all of column A to M
      Set rng = .Find(FindString, , LookIn:=xlValues, LookAt:=xlWhole, _
        SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
      If Not rng Is Nothing Then
        On Error Resume Next
        Set ret = Application.InputBox(Prompt:="Please select a range where you want to paste", Type:=8)
        On Error GoTo 0
        If Not ret Is Nothing Then
          rng.CurrentRegion.Copy ret
        End If
      Else
        MsgBox "Nothing found" 'value not found
      End If
    End With
  End If
  
End Sub

 

[Jd1uth]

Hallo DanteAmor, thanks for the help the code works it stays on cheet1 now.
But one problem that I now have is that it not copy the text and the make up but also the formula in a cell
It just must copy the make up of the cell and the text in to Sheet 1 not the formula then i get #VERW! when past it

 

[Jd1uth]

HI I found the solution.

Sub Find_First()
  Dim FindString As String
  Dim rng As Range, ret As Range
 
  FindString = InputBox("Enter a Search value")
  If Trim(FindString) <> "" Then
    With Sheets("Sheet2").Range("A3:DM3") 'searches all of column A to M
      Set rng = .Find(FindString, , LookIn:=xlValues, LookAt:=xlWhole, _
        SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
      If Not rng Is Nothing Then
        On Error Resume Next
        Set ret = Application.InputBox(Prompt:="Please select a range where you want to paste", Type:=8)
        On Error GoTo 0
        If Not ret Is Nothing Then
          rng.CurrentRegion.Copy
          
          ret.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
        
        ret.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
        
        End If
      Else
        MsgBox "Nothing found" 'value not found
      End If
    End With
  End If
 
End Sub

 

[DanteAmor]

But one problem that I now have is that it not copy the text and the make up but also the formula in a cell

In your original code you are pasting everything, that's why I was also pasting everything.


I put my updated code

Sub Find_First()
  Dim FindString As String
  Dim rng As Range, ret As Range
  
  FindString = InputBox("Enter a Search value")
  If Trim(FindString) <> "" Then
    With Sheets("Sheet2").Range("A3:DM3") 'searches all of column A to DM in row 3
      Set rng = .Find(FindString, , xlValues, xlWhole, xlByRows, xlNext, False)
      If Not rng Is Nothing Then
        On Error Resume Next
        Set ret = Application.InputBox(Prompt:="Please select a range where you want to paste", Type:=8)
        On Error GoTo 0
        If Not ret Is Nothing Then
          rng.CurrentRegion.Copy
          ret.PasteSpecial xlPasteValues
          ret.PasteSpecial xlPasteFormats
        End If
      Else
        MsgBox "Nothing found" 'value not found
      End If
    End With
  End If
  
End Sub

 

[Jd1uth]

Thanks , yes you are right I was testing on blank sheets did not have that problem, there where no formula.
Can you make the code so that it ask for how many copy to past in one input box.
only problem is that i get 3 popups then that's not so nice.
InputBox("Enter a Search value")
InputBox(Prompt:="Please select a range where you want to paste",
InputBox(Prompt:="How many copies",
Is it possible to make this one box?

 

[DanteAmor]

Can you make the code so that it ask for how many copy to past in one input box.

What do you mean by that?
For example, if I want it 3 times.
Do you want to copy once and paste to cell 1, then paste to cell 2 and paste to cell 3?
You can explain it.

Instead of several inputboxes, you could create a userform.

 

[Jd1uth]

No the Code makes a selection of 5 cells on Sheet2 copy this to a selected cell on sheet1 also the 5 cells
I like that it ask how many times it has to past the cells (5) it have to be past in the same colomn under the first 5 cells.

select cells (5) sheet2 (then how many copies) then Past to sheet1, when input is 3 times it copies 15 cells in the same colomn.
when 2 times it copies 10 same colomn

 

[DanteAmor]

I like that it ask how many times it has to past the cells (5) it have to be past in the same colomn under the first 5 cells.

Try:

Sub Find_First()
  Dim FindString As String
  Dim rng As Range, ret As Range
  Dim nTime As Variant
  Dim i As Long
  
  FindString = InputBox("Enter a Search value")
  If Trim(FindString) <> "" Then
    With Sheets("Sheet2").Range("A3:DM3") 'searches all of column A to DM in row 3
      Set rng = .Find(FindString, , xlValues, xlWhole, xlByRows, xlNext, False)
    End With
    
    If Not rng Is Nothing Then
      On Error Resume Next
      Set ret = Application.InputBox(Prompt:="Please select a range where you want to paste", Type:=8)
      On Error GoTo 0
      If Not ret Is Nothing Then
      
        nTime = Application.InputBox("how many copy to past", Type:=1)
        
        If nTime = False Then Exit Sub
      
        rng.CurrentRegion.Copy
        For i = 1 To nTime
          ret.PasteSpecial xlPasteValues
          ret.PasteSpecial xlPasteFormats
          Set ret = Cells(Rows.Count, ret.Column).End(3)(2)
        Next
        
      End If
    Else
      MsgBox "Nothing found" 'value not found
    End If
  End If
  
End Sub

 

[Jd1uth]

Yes exactly what i mean Perfect.
thank You
I will try to make a Userform next and get the code in there. I Hope