Question

工作簿包含三张表：

项目样式（在colA中包含项目编号，colB项目的样式）
样式（我们想要的样式列表）
样式模板（cols中指定的样式中的项目列表）

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

从样式表中复制样式列表并粘贴＆amp;从第2行开始在样式模板中转置。所有列的第1行需要留空。
宏需要逐个选择样式模板中的每个样式，现在它们位于不同的列中。这些将是搜索条件。
根据在步骤2中选择的样式，宏需要在项目样式表中进行搜索并选择具有所选样式的所有项目，并将所有这些项目粘贴到相应样式下的样式中 - 模板表。如果没有与所选样式对应的项目，则应在相应样式下方提及“无项目”。

这是一个易于理解的工作簿链接

虽然工作簿只提到了三种样式，但宏应该能够处理超过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

循环遍历列以查找搜索条件并粘贴条件下的另一个工作表中的单元格值

1 个答案: