從一張工作表復制數據並將其粘貼到另一張工作表上

Question

我需要一個 excel vba 代碼，如果滿足給定的條件，它會從一張紙中復制數據並將其粘貼到另一張紙上。 工作簿中有兩張工作表（工作表 1 和工作表 2）。 基本上，表 2 列“C”中的數據必須復制到表 1 列“C”。

條件是： -

SHEET 1&2 A,B,C 中將有三列。

如果 SHEET 1 B1 有一個數據讓我們取（“88”）。現在，它應該搜索 sheet2 B:B 中有多少（“88”）。

如果有多個讓我們取“4”，那么那些“4”sheet2“C”值屬於工作表 1“A1”。 它應該使用“sheet1 A1 & B1”值創建另外三行，那么這 4 個值必須粘貼在“sheet1”c”中，與這四個“Sheet A1&B1”相鄰。我無法選擇這 4 個 SHEET2“C”值

如果有一個“88”，那么它可以粘貼在sheet1“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 時，請參閱備注部分了解如何在“環繞”到開始后停止搜索，否則您將進入無限循環。

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