Скопируйте данные с одного листа и вставьте их на другой лист

Question

Мне нужен код Excel VBA, который копирует данные с одного листа и вставляет их на другой лист, если заданные условия удовлетворены. В рабочей тетради будет два листа (лист1 и лист 2). В основном данные в столбце листа 2 "C" должны быть скопированы в столбец листа 1 "C".

Условия: -

В ЛИСТЕ 1 и 2 будет три столбца A, B, C.

ЕСЛИ ЛИСТ 1 B1 имеет данные, которые мы возьмем («88»). Теперь он должен найти, сколько из них («88») есть на листе 2 B: B.

Если их больше одного, возьмем «4», тогда эти значения «4» sheet2 »C» относятся к листу 1 «A1». Он должен создать еще три строки со значением "sheet1 A1 & B1", после чего эти 4 значения должны быть вставлены в "sheet1" c "рядом с этими четырьмя" Sheet A1 & B1 ". Я не могу выбрать эти 4 SHEET2" C "VALUES

Если есть один" 88 ", он может просто вставить на лист 1" C1 ".

Таким образом, это должно быть сделано для каждого значения в листе 1 B: B.

Хотя бы Скажите, какой код используется для добавления строк со значением ячейки через vba

Как найти значение и скопировать соответствующую ячейку

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

См. Найти и FindNext

При использовании FindNext см. Раздел «Примечания», чтобы узнать, как остановить поиск после «переноса» к началу, в противном случае вы попадаете в бесконечная л oop.

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