excel - 遍历列以查找搜索条件并将单元格值从另一个工作表粘贴到条件下方

Question

该工作簿包含三个工作表：

1. item-style（colA中包含item编号，colB中包含item的样式）

2. 样式（我们想要的样式列表）

3. 样式模板（列中指定样式内的项目列表）

我需要一个做三件事的宏：

1. 从样式表中复制样式列表，然后在样式模板中从第 2 行开始粘贴和转置。所有列的第 1 行需要留空。

2. 宏需要逐一选择样式模板中的每个样式，现在在不同的列中。这些将是搜索条件。

3. 宏需要根据步骤2中选择的样式在item-style sheet中进行搜索，选择所有具有所选样式的item，并将这些items全部粘贴到style-template sheet中相应样式的下方。如果没有与所选样式对应的项目，则应在相应样式下方注明“无项目”。

这是工作簿的链接，便于理解

风格项目

虽然工作簿只提到了三种样式，但宏应该能够处理超过 50 种样式。

这是我的代码：

Sub StyleProject()
Application.ScreenUpdating = False

Dim ws As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet

Set ws = Sheets("Item-Style")
Set ws2 = Sheets("Style")
Set ws3 = Sheets("Style Template")

Dim rng As Range, secRng As Range

Dim i, j, k

Sheets("Style Template").Activate
finalcol = Cells(2, 50).End(x1toleft).Column

For i = 2 To finalcol

j = Cells(2, i).Value

lr = ws.Range("A" & Rows.Count).End(xlUp).Row

For k = 2 To lr
    Set rng = ws.Range("B" & i)

    If StrComp(CStr(rng.Text), j, 1) = 0 Then
        ws.Rows(k & ":" & k).Copy
        nxtRow = ws3.Range(i & Rows.Count).End(xlUp).Row + 1
        ws2.Rows(nxtRow & ":" & nxtRow).PasteSpecial Paste:=xlPasteValues, _
        Operation:=xlNone, SkipBlanks:=False, Transpose:=False


         Set rng = Nothing
            End If
        Next k

Next i
Application.ScreenUpdating = True
End Sub

试图找出我相信的 nextrng 最终会出错。

Answer 1

Sub StyleProject()

    Dim wsStyle As Worksheet
    Dim wsData As Worksheet
    Dim wsTemplate As Worksheet
    Dim StyleCell As Range
    Dim rngFound As Range
    Dim arrResults() As Variant
    Dim strFirst As String
    Dim ResultIndex As Long
    Dim StyleIndex As Long

    Set wsStyle = Sheets("Style")
    Set wsData = Sheets("Item Data")
    Set wsTemplate = Sheets("Style Template")

    With wsStyle.Range("A2", wsStyle.Cells(Rows.Count, "A").End(xlUp))
        If .Row < 2 Then Exit Sub   'No data
        ReDim arrResults(1 To 1 + Evaluate("MAX(COUNTIF(" & wsData.Columns("B").Address(External:=True) & "," & .Address(External:=True) & "))"), 1 To .Cells.Count)
        For Each StyleCell In .Cells
            StyleIndex = StyleIndex + 1
            ResultIndex = 1
            arrResults(ResultIndex, StyleIndex) = StyleCell.Text
            Set rngFound = wsData.Columns("B").Find(StyleCell.Text, wsData.Cells(Rows.Count, "B"), xlValues, xlWhole)
            If Not rngFound Is Nothing Then
                strFirst = rngFound.Address
                Do
                    ResultIndex = ResultIndex + 1
                    arrResults(ResultIndex, StyleIndex) = wsData.Cells(rngFound.Row, "A").Text
                    Set rngFound = wsData.Columns("B").Find(StyleCell.Text, rngFound, xlValues, xlWhole)
                Loop While rngFound.Address <> strFirst
            End If
        Next StyleCell
    End With

    If UBound(arrResults, 1) > 1 Then
        wsTemplate.Range("B2", wsTemplate.Cells(Rows.Count, Columns.Count)).Clear
        wsTemplate.Range("B2").Resize(UBound(arrResults, 1), UBound(arrResults, 2)).Value = arrResults
        With wsTemplate.Range("B2").Resize(, UBound(arrResults, 2))
            .Font.Bold = True
            .Borders(xlEdgeBottom).LineStyle = xlContinuous
            .EntireColumn.AutoFit
        End With
    End If

    Set wsStyle = Nothing
    Set wsData = Nothing
    Set wsTemplate = Nothing
    Set StyleCell = Nothing
    Set rngFound = Nothing
    Erase arrResults

End Sub