Data extraction based on condition

[kamranyd]

Sub transfer()
Dim i As Long, j As Long, lastrow1 As Long, lastrow2 As Long
Dim myname As String
lastrow1 = Sheets("sheet1").Range("A" & Rows.Count).End(xlUp).Row


Worksheets("Sheet1").Select
Application.ScreenUpdating = False


For i = 2 To lastrow1
myname = Sheets("sheet1").Cells(i, "A").Value


Sheets("sheet2").Activate
lastrow2 = Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row


For j = 2 To lastrow2


If Sheets("sheet2").Cells(j, "A").Value = myname Then
Sheets("sheet1").Activate
Sheets("sheet1").Range(Cells(i, "B"), Cells(i, "G")).Copy
Sheets("sheet2").Activate
Sheets("sheet2").Range(Cells(j, "B"), Cells(j, "C")).Select
ActiveSheet.Paste
End If


Next j
Application.CutCopyMode = False
Next i
Sheets("sheet2").Activate
Sheets("sheet2").Range("A1").Select
End Sub

can somebody help with these codes which extract data as per given names. i want help to copy values from anywhere from cells of data sheet and copy in another sheet any given cell. which part of codes i shall change. Thanks

 

[Fluff]

Is this what you're after

Sub CopyFilter()
   Dim Cl As Range
   Dim Ws1 As Worksheet
   Dim Ws2 As Worksheet
   
   Set Ws1 = Sheets("Sheet1")
   Set Ws2 = Sheets("Sheet2")
   With CreateObject("scripting.dictionary")
      For Each Cl In Ws2.Range("A2", Ws2.Range("A" & Rows.Count).End(xlUp))
         If Not .exists(Cl.Value) Then .Add Cl.Value, Cl.Offset(, 1)
      Next Cl
      For Each Cl In Ws1.Range("A2", Ws1.Range("A" & Rows.Count).End(xlUp))
         If .exists(Cl.Value) Then Cl.Offset(, 1).Resize(, 6).Copy .Item(Cl.Value)
      Next Cl
   End With
End Sub

 

[kamranyd]

thankx
the codes which i share above also do same data filter and copy. but i need when it filter data and copy it should copy as per my given cells where ever i want dnot copy as a row. and if the filter data doesnt find given name or number it should show message nothing found.

 

[Fluff]

I'm afraid I don't understand what you are asking.
Can you please give some examples.

 

[kamranyd]

i mean your given codes work fine, but it copy range of cells to another sheet as range. whereas i want it should copy range of cells in another sheet but on different cells whatever cells i give. for example it copy values after filter from B to D cells and paste on D5 and E8 and G10 or any other cell i want.
it should show me pop message if the filter data not found in database.

 

[Fluff]

How will the code know which cells to copy & where to paste them?

 

[kamranyd]

https://drive.google.com/open?id=13-N8BCM0f8QS61A5KdVWkRHaE9yvJiZv
sample file

now u got me thank God....check the file it copy complete range from sheet1 to sheet2. but i want copy cells values whatever cell i want to copy from and paste on another sheet as per my given cells.

 

[Fluff]

Ok, try this

Sub CopyFilter()
   Dim Cl As Range
   Dim Ws1 As Worksheet
   Dim Ws2 As Worksheet
   
   Set Ws1 = Sheets("Sheet1")
   Set Ws2 = Sheets("Sheet2")
   With CreateObject("scripting.dictionary")
      For Each Cl In Ws2.Range("A2", Ws2.Range("A" & Rows.Count).End(xlUp))
         If Not .exists(Cl.Value) Then .Add Cl.Value, Cl.Offset(, 1)
      Next Cl
      For Each Cl In Ws1.Range("A2", Ws1.Range("A" & Rows.Count).End(xlUp))
         If .exists(Cl.Value) Then
            Cl.Offset(, 1).Resize(, 3).Copy .Item(Cl.Value)
            Cl.Offset(, 4).Copy .Item(Cl.Value).Offset(, 4)
            Cl.Offset(, 5).Copy .Item(Cl.Value).Offset(, 6)
            Cl.Offset(, 6).Copy .Item(Cl.Value).Offset(, 8)
         End If
      Next Cl
   End With
End Sub

 

[kamranyd]

thanks this what i need. Thanks so much....since 3 hours i was trying myself... actually not gud with codes....1 last thing can you add codes which can clear previous cells and paste again. if they dont find value in sheet1 it should show pop message not found.

 

[Fluff]

Try

Sub CopyFilter()
   Dim Cl As Range
   Dim Ws1 As Worksheet
   Dim Ws2 As Worksheet
   Dim Flg As Boolean
   
   Set Ws1 = Sheets("Sheet1")
   Set Ws2 = Sheets("Sheet2")
   With CreateObject("scripting.dictionary")
      For Each Cl In Ws2.Range("A2", Ws2.Range("A" & Rows.Count).End(xlUp))
         If Not .exists(Cl.Value) Then .Add Cl.Value, Cl.Offset(, 1)
      Next Cl
      For Each Cl In Ws1.Range("A2", Ws1.Range("A" & Rows.Count).End(xlUp))
         If .exists(Cl.Value) Then
            Flg = True
            Range("2:1048576").ClearContents
            Cl.Offset(, 1).Resize(, 3).Copy .Item(Cl.Value)
            Cl.Offset(, 4).Copy .Item(Cl.Value).Offset(, 4)
            Cl.Offset(, 5).Copy .Item(Cl.Value).Offset(, 6)
            Cl.Offset(, 6).Copy .Item(Cl.Value).Offset(, 8)
         End If
      Next Cl
   End With
   If Flg = False Then MsgBox "Nothing Found"
End Sub