Copy the data from one sheet and paste it on the other sheet

Question

I need an excel vba code which copy the data from one sheet and paste it on the other sheet if the given conditions satisfied. There will be two sheets in a workbook (sheet1 and sheet 2). Basically the data in sheet 2 column "C" must be copy to sheet 1 column "C".

The conditions are : -

There will be three columns in SHEET 1&2 A,B,C .

IF SHEET 1 B1 has a data let us take("88").Now,it should search how many of them ("88") are there in sheet2 B:B.

If there are more than one let us take "4" then those "4" sheet2 "C" values are belongs to the sheet 1 "A1". It should create another three rows with "sheet1 A1 & B1" Value then those 4 values must be paste in "sheet1 "c" beside those four "Sheet A1&B1". iam unable to select those 4 SHEET2 "C" VALUES

If there is one "88" then it can just paste at sheet1"C1".

In this way it should do for every value in sheet 1 B:B.

At least Tell me what code is used to add rows with cell value through vba

How To Find Value & Copy Corresponding Cell

Sub copythedata()

 Dim r As Long, ws As Worksheet, wd As Worksheet

 Dim se As String
 Dim sf As String
 Dim fn As Integer
 Dim y As Integer
 Dim lrow As Long

 Set ws = Worksheets("sheet2")
 Set wd = Worksheets("sheet1")

    y = 123
    x = wd.Cells(Rows.Count, 1).End(xlUp).Row
    MsgBox "Last Row: " & x
If x > y Then
    wd.Range(wd.Cells(y, 1), wd.Cells(x, 1)).EntireRow.Delete Shift:=xlUp
End If

    For r = wd.Cells(Rows.Count, "B").End(xlUp).Row To 2 Step -1

fn = Application.WorksheetFunction.countif(ws.Range("B:B"), wd.Range("B" & r).Value)


        If fn = 1 Then
        wd.Range("C" & r).Value = ws.Range("C" & r).Value

        ElseIf fn > 1 Then
        se = wd.Range(wd.Cells(A, r), wd.Cells(B, r)).EntireRow.Copy

        wd.Range("A123").Rows(fn - 1).Insert Shift:=xlShiftDown

        Else

        wd.Range("C" & r).Value = "NA"


        End If
    Next r

End Sub

Answer 1

See Find and FindNext

When using FindNext see the Remarks section for how to stop search after the 'wraparound' to the start, otherwise you get into an endless loop.

Option Explicit
Sub copythedata()

    Dim wb As Workbook, ws1 As Worksheet, ws2 As Worksheet
    Dim iLastRow1 As Integer, iLastRow2 As Long
    Dim iRow As Integer, iNewRow As Long, iFirstFound As Long
    Dim rngFound As Range, rngSearch As Range
    Dim cell As Range, count As Integer

    Set wb = ThisWorkbook
    Set ws1 = wb.Sheets("Sheet1")
    Set ws2 = wb.Sheets("sheet2")

    ' sheet 2 range to search
    iLastRow2 = ws2.Range("B" & Rows.count).End(xlUp).Row
    Set rngSearch = ws2.Range("B1:B" & iLastRow2)

    'Application.ScreenUpdating = False

    ' sheet1 range to scan
    iLastRow1 = ws1.Range("B" & Rows.count).End(xlUp).Row

    ' add new rows after a blank row to easily identify them
    iNewRow = iLastRow1 + 1

    For iRow = 1 To iLastRow1
        Set cell = ws1.Cells(iRow, 2)

        Set rngFound = rngSearch.Find(what:=cell.Value, _
            LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)

        If rngFound Is Nothing Then
            'Debug.Print "Not found ", cell
            cell.Offset(0, 1) = "NA"
        Else
            iFirstFound = rngFound.Row
            Do
                'Debug.Print cell, rngFound.Row
                If rngFound.Row = iFirstFound Then
                   cell.Offset(0, 1) = rngFound.Offset(0, 1).Value
                Else
                   iNewRow = iNewRow + 1
                   ws1.Cells(iNewRow, 1) = cell.Offset(, -1)
                   ws1.Cells(iNewRow, 2) = cell.Offset(, 0)
                   ws1.Cells(iNewRow, 3) = rngFound.Offset(0, 1).Value
                End If
                Set rngFound = rngSearch.FindNext(rngFound)
            Loop Until rngFound.Row = iFirstFound
        End If

    Next

    Application.ScreenUpdating = True
    MsgBox "Finished", vbInformation

End Sub