Question

当前代码 - 我编写了一个代码，在其中它将搜索Sheet2 B1单元格中的值，在工作表1中复制粘贴整个列“Column C”和“column” d。”

必需 - 我想循环同样的事情，一旦执行了表2中的B1，检查B2中的值（sheet2），在Sheet1中，如果找到，则创建一个新工作表并粘贴整个“C列和D列”中的列值。循环应该运行到Sheet2列B中的所有行，并且对于找到的每个值创建新的工作表和粘贴。

请帮我循环并编辑此代码。

当前代码

  Sub Look_copy()

Dim sh1 As Worksheet, sh2 As Worksheet
    Dim K As Long, l As Long, i As Long, nRow As Long
    Dim valuee1 As Variant


Set sh1 = Sheets("Sheet1")
    Set sh2 = Sheets("Sheet2")
    K = 3
    l = 4
    nRow = 1
    valuee1 = Sheet2.Range("B1").Value

    For i = 1 To Columns.Count
        If sh1.Cells(nRow, i).Value = valuee1 Then
            sh1.Cells(nRow, i).EntireColumn.Copy sh2.Cells(1, K)
            sh1.Cells(nRow, i + 1).EntireColumn.Copy sh2.Cells(1, l)
            K = K + 1
            l = l + 1
        End If
    Next i
End Sub

Answer 1

从您的代码中我可以理解您在第一行中找到了一个值，将整列复制到了Sheet1的COl C和D.下面的代码执行相同的操作，但也为第2页B列中的每个单元格循环，并在粘贴之前添加新的工作表。试试吧！

Sub Macro2()
    Dim newSheet As Worksheet
    Dim x As Range

    'loop unitl last row in sheet2 column b
    For i = 1 To Sheets("Sheet2").Range("B" & Rows.Count).End(xlUp).Row  

        'find value in sheet1
        Set x = Sheets("Sheet1").Rows("1:1").Find(What:=Sheets("Sheet2").Range("B" & i), LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)

        'if value found
        If Not x Is Nothing Then

            'add new sheet
            Sheets.Add After:=Sheet1
            Set newSheet = ActiveSheet

            'copy entire column to column C nad D of new sheet
            Sheets("Sheet1").Columns(x.Column).Copy newSheet.Columns(3)
            Sheets("Sheet1").Columns(x.Column).Copy newSheet.Columns(4)
        End If
    Next i

End Sub

<强>更新

在代码下面检查sheet3中C列的值。对于Sheet2 C列中的每个值，它将在Sheet3 Row1中找到匹配值，并将值复制到最后一行到最后一行可用行的Sheet2列B.

Sub Macro3()
    Dim newSheet As Worksheet
    Dim x As Range

    'loop unitl last row in sheet2 column b
    For i = 1 To Sheets("Sheet2").Range("C" & Rows.Count).End(xlUp).Row

        'find value in sheet1
        Set x = Sheets("Sheet3").Rows("1:1").Find(What:=Sheets("Sheet2").Range("C" & i), LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)

        'if value found
        If Not x Is Nothing Then

            With Sheets("Sheet3")
                .Range(x, .Cells(Rows.Count, x.Column).End(xlUp)).Copy _
                    Destination:=Sheets("Sheet2").Range("B" & Rows.Count).End(xlUp).Offset(1, 0)
            End With

        End If
    Next i

End Sub

Answer 2

这应该做：

Option Explicit

Sub Look_copies()
    Dim rng1 As Range, cell As Range

    With Sheets("Sheet1")
        Set rng1 = .Range("A1", .Cells(1, .Columns.Count).End(xlToLeft))
    End With

    With Sheets("Sheet2")
        For Each cell In .Range("B1", .Cells(.Rows.Count, "B")).End(xlUp).SpecialCells(xlCellTypeConstants)
            If WorksheetFunction.CountIf(rng1, cell.Value) > 0 Then Look_copy cell, rng1, Sheets.Add(after:=Sheets(Sheets.Count))
        Next
    End With
End Sub


Sub Look_copy(valCell As Range, rng1 As Range, pasteSht As Worksheet)
    Dim valuee1 As Variant
    Dim cell As Range

    valuee1 = valCell.Value
    For Each cell In rng1
        If cell.Value = valuee1 Then
            cell.EntireColumn.Copy
            pasteSht.Cells(1, "C").Resize(, 2).PasteSpecial
            Application.CutCopyMode = False
        End If
    Next
End Sub

嵌套for循环的VBA代码，查看特定值并复制粘贴其他工作表中的整个列

2 个答案: