Question

我需要一个excel vba代码，如果满足给定条件，该代码将从一张纸中复制数据并将其粘贴到另一张纸上。工作簿中将有两张纸（第一张和第二张）。基本上，工作表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个值在这四个“ Sheet A1＆B1”旁边粘贴“ sheet1“ c”。无法选择这四个SHEET2“ C”值

如果有一个“ 88”，则可以粘贴到工作表“ 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

请参见Find和 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

复制一张纸上的数据并将其粘贴到另一张纸上

1 个答案: