vba无法运行，我很难找出完整的代码来实现我的目标。不胜感激！

Question

我尝试执行以下操作，但在执行操作时被卡住了。

我要实现的目标：

在各种工作表的标题范围内搜索特定的文本/值（来自不同工作表“ DB”的特定文本/值）
找到具有该值的标题时，将所有数据复制到该标题下，并将其作为值粘贴到同一列中
然后，将具有匹配标题的列右侧的第1列的公式复制到相应工作表的特定列的最后一行的“粘贴公式”（例如，如果在H11上找到具有该值的标题，复制I12的公式并将其粘贴到I列中A的最后一行）
对各种工作表范围内的所有标题重复此操作

我搜索了各种来源以提供以下代码。

我到目前为止的代码：

Dim Lr1,lr2,lr3,lr4 As Long
Dim rng, c, rngAddress As Range
Dim period As String

period = Worksheets("DB").Range("Y1")
Lastrow1 = Worksheets("Calc_1").Cells(Rows.Count, "A").End(xlUp).Row
Lastrow2 = Worksheets("Calc_2").Cells(Rows.Count, "A").End(xlUp).Row
Lastrow3 = Worksheets("Calc_3").Cells(Rows.Count, "A").End(xlUp).Row
Lastrow4 = Worksheets("Calc_4").Cells(Rows.Count, "A").End(xlUp).Row

With Worksheets("Calc_1", "Calc_2", "Calc_3", "Calc_4")

    Set rng = Activesheet.Range("G11:Z11")

    For Each c In rng

        If c = period Then

            Range(c, c.End(xlDown)).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
 'cannot figure out the column to the right aspect here

        Else

        End If

    Next

End With

vba无法运行，我很难找出完整的代码来实现我的目标。不胜感激！

这是我编辑后的内容：

Dim period As String
Dim ws As Worksheet
Dim rng As Range

period = Worksheets("Model_DB").Range("Y1")
Lastrow1 = Worksheets("Calc_1").Range("A" & .Rows.Count).End(xlUp).Row
Lastrow2 = Worksheets("Calc_2").Range("A" & .Rows.Count).End(xlUp).Row
Lastrow3 = Worksheets("Calc_3").Range("A" & .Rows.Count).End(xlUp).Row

For Each ws In ThisWorkbook.Sheets
    Select Case ws.Name
    Case "Calc_1", "Calc_2", "Calc_3"
        With ws
            For Each rng In .Range("G11:Z11")
                If rng.Value = period Then
                   '/change to value/
                    Range(rng).Select.Copy
                    Range(rng & Lastrow1).Paste Special=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

                    '/put formula on the right column/
                    fn.Offset(1, 1).Copy
                    Range(rng & Lastrow1).Paste Special=xlPasteformulas, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    Exit For
                End If
            Next rng
        End With
    End Select
Next ws

Answer 1

我会在您的代码中推荐很多东西。

在各种工作表的标题范围内搜索特定的文本/值（来自不同工作表“ DB”的特定文本/值）找到具有该值的标头后，复制该标头下方的所有数据并将其作为值粘贴到同一列中

A。 Dim Lr1,lr2,lr3,lr4 As Long

在上面的代码中，只有最后一个变量lr4被声明为Long，其余变量将被声明为Variants。将其替换为Dim Lr1 As Long,lr2 As Long,lr3 As Long,lr4 As Long。 Variants会降低代码的运行速度，因为在运行时，代码必须将其转换为相关的数据类型。除非必要，否则应避免使用它们。

B。 With Worksheets("Calc_1", "Calc_2", "Calc_3", "Calc_4")请勿这样做。如果标题在其他列中怎么办？循环浏览工作表并使用Select Case处理相关工作表

C。 Selection.PasteSpecial Paste:=xlPasteValues.....您要粘贴而不复制吗？正如我在评论中提到的，我不建议在这种情况下使用xlDown。您正在正确地计算代码开头的最后一行。使用它来定义您的范围。但是，您要实现的目标可以仅一行完成，而不是复制并粘贴特殊内容。

您的代码可以缩短为（未经测试）

Option Explicit

Sub Sample()
    Dim period As String
    Dim ws As Worksheet
    Dim rng As Range

    period = Worksheets("DB").Range("Y1")

    For Each ws In ThisWorkbook.Sheets
        Select Case ws.Name
        Case "Calc_1", "Calc_2", "Calc_3", "Calc_4"
            With ws
                For Each rng In .Range("G11:Z11")
                    If rng.Value = period Then
                        .Columns(rng.Column).Value = .Columns(rng.Column).Value
                        Exit For
                    End If
                Next rng
            End With
        End Select
    Next ws
End Sub

如果您在上述代码中遇到任何错误，请告诉我。

D。 Lastrow1 = Worksheets("Calc_1").Cells(Rows.Count, "A").End(xlUp).Row。为了安全起见，也请完全符合Rows.Count的条件。我建议您阅读THIS。

关于第3点和第4点，请像您对第1点和第2点所做的那样显示一些努力，我们将从那里开始。：）

excel vba查找具有特定值的标头并复制以下值

vba无法运行，我很难找出完整的代码来实现我的目标。不胜感激！

1 个答案: