将包含特定值的单元格复制到另一列跳过空白答案

【问题标题】：Copy cells containing specific values into another column skipping blanks将包含特定值的单元格复制到另一列跳过空白
【发布时间】：2017-06-05 21:59:04
【问题描述】：

我在 B 列中有问题列表，在 C 列中有相关状态。我只想将状态为“准备测试”、“内置产品”、“进行中”或“等待 CAB 批准”的问题复制到 D 列，并且不希望中间有空白单元格。

我略微修改了本主题中的代码，但无法使其适用于四种不同的状态类型（我尝试添加 ElseIf 语句，但似乎不起作用）：

Copy all cells with certain value into another column skipping blanks

Sub RangeCopyPaste()
Dim cell As Range
Dim NewRange As Range
Dim MyCount As Long
MyCount = 1

'--> Loop through each cell in column C
'--> Add each cell in column B with value "Ready for Testing" in column B to 
NewRange
For Each cell In Worksheets("OverviewTest").Range("C6:C56")
    If cell.Value = "Ready for Testing" Then
        If MyCount = 1 Then Set NewRange = cell.Offset(0, -1)
        Set NewRange = Application.Union(NewRange, cell.Offset(0, -1))
        MyCount = MyCount + 1
    End If
Next cell

'--> Copy NewRange from inactive sheet into active sheet
NewRange.Copy Destination:=ActiveSheet.Range("D6")


End Sub

在此先感谢您提供的任何帮助，我是 Excel VBA 的新手。

2017 年 2 月 6 日更新

我创建了我的文件的简化版本，以演示我想要实现的目标。我的原始文件有很多标签，每个标签有更多的列和数百行。（抱歉，它不允许我添加多张图片，所以我不得不上传一张大图）

Sheet2 - 包含有关作业的所有详细信息

Sheet1 - 我希望这是仅显示活动作业的概览选项卡。 A 列包含指向工作表 2 中的更改的超链接。F 列具有条件格式，如果复制单元格，则会删除该格式，因此我使用 VLOOKUP 代替

当我从 Tom 或 Scott 运行原始脚本时（D 和 E 列有一个单独的循环），详细信息被正确复制，但超链接没有被复制。当我运行新脚本时，E 列被正确复制，但 D 和 F 列由于某种原因没有正确复制。我认为原始脚本适用于 E 列，但对于 D 列，是否有保留超链接的方法？ https://i.stack.imgur.com/clR2b.jpg

原始脚本

Sub RangeCopyPaste()
Dim cell As Range
Dim NewChangeRange As Range
Dim NewDetailRange As Range


Set NewChangeRange = Range("D6") 'Set the first destination cell

For Each cell In Worksheets("Sheet1").Range("C6:C14") 'Loop through your Status column
    Select Case cell.Value 'Select Case is an alternative to writing multiple If, ElseIf statements, particularly if you want it to run the same code when it is true.
        Case "Ready for Testing", "Build in Prod", "In Progress", "Awaiting CAB Approval" 'Specify all the values which would consitute a "True" result
            NewChangeRange.Value = cell.Offset(0, -2).Value 'In the destination cell, take the cell value 1 column to the left of the cell which contained the required status
            Set NewChangeRange = NewChangeRange.Offset(1, 0) 'Setup the new destination cell ready for the next "True" result
    End Select
Next cell


Set NewDetailRange = Range("E6") 'Set the first destination cell

For Each cell In Worksheets("Sheet1").Range("C6:C14") 'Loop through your Status column
    Select Case cell.Value 'Select Case is an alternative to writing multiple If, ElseIf statements, particularly if you want it to run the same code when it is true.
        Case "Ready for Testing", "Build in Prod", "In Progress", "Awaiting CAB Approval" 'Specify all the values which would consitute a "True" result
            NewDetailRange.Value = cell.Offset(0, -1).Value 'In the destination cell, take the cell value 1 column to the left of the cell which contained the required status
            Set NewDetailRange = NewDetailRange.Offset(1, 0) 'Setup the new destination cell ready for the next "True" result
    End Select
Next cell

End Sub

新脚本

Sub RangeCopyPaste()
    Dim cell As Range
    Dim NewChangeRange As Range
    Dim NewDetailRange As Range


    Set NewChangeRange = Range("D6") 'Set the first destination cell

    For Each cell In Worksheets("Sheet1").Range("C6:C14") 'Loop through your Status column
        Select Case cell.Value 'Select Case is an alternative to writing multiple If, ElseIf statements, particularly if you want it to run the same code when it is true.
            Case "Ready for Testing", "Build in Prod", "In Progress", "Awaiting CAB Approval" 'Specify all the values which would consitute a "True" result
                Range(cell.Offset(0, -2), cell.Offset(0, -2)).Copy NewChangeRange
                Set NewChangeRange = NewChangeRange.Offset(1, 0) 'Setup the new destination cell ready for the next "True" result
        End Select
    Next cell


    Set NewDetailRange = Range("E6") 'Set the first destination cell

    For Each cell In Worksheets("Sheet1").Range("C6:C14") 'Loop through your Status column
        Select Case cell.Value 'Select Case is an alternative to writing multiple If, ElseIf statements, particularly if you want it to run the same code when it is true.
            Case "Ready for Testing", "Build in Prod", "In Progress", "Awaiting CAB Approval" 'Specify all the values which would consitute a "True" result
                NewDetailRange.Value = cell.Offset(0, -1).Value 'In the destination cell, take the cell value 1 column to the left of the cell which contained the required status
                Set NewDetailRange = NewDetailRange.Offset(1, 0) 'Setup the new destination cell ready for the next "True" result
        End Select
    Next cell

    End Sub

【问题讨论】：

标签： vba excel

【解决方案1】：

试试下面的代码来解决你的问题；

Sub RangeCopyPaste()
Dim cell As Range
Dim NewRange As Range

Set NewRange = Range("D1") 'Set the first destination cell

For Each cell In Worksheets("Sheet1").Range("C1:C16") 'Loop through your Status column
    Select Case cell.Value 'Select Case is an alternative to writing multiple If, ElseIf statements, particularly if you want it to run the same code when it is true.
        Case "Ready for testing", "Build in Prod", "In Progress", "Awaiting CAB Approval" 'Specify all the values which would consitute a "True" result
            NewRange.Formula = Range(cell.Offset(0, -2), cell.Offset(0, -2)).Formula 'Copies the formula from Column A
            NewRange.Offset(0, 1).Value = Range(cell.Offset(0, -1), cell.Offset(0, -1)).Value ' Copies the value from Column B
            NewRange.Offset(0, 2).Value = Range(cell).Formula ' Copies the formula from Column C
            Set NewRange = NewRange.Offset(1, 0) 'Setup the new destination cell ready for the next "True" result
    End Select
Next cell

End Sub

【讨论】：

感谢您的替代方案和有用的解释。是否可以修改上述代码，将 A1、B1、C1 复制到 D1、E1、F1 中，其中 C1 中存在 True 结果？
当然可以。将“NewRange.Value = cell.Offset(0,-1).Value”替换为 Range(cell.Offset(0,-2),cell.Offset(0,3))。复制 NewRange 还将 NewRange 设置更改为它目前会覆盖数据。
嗨，汤姆，感谢您提供的新信息，但它与我正在尝试做的事情并不完全一致。我已经用屏幕截图更新了我的原始问题，因为我无法在此处添加它们。
嗨，布赖恩，您的问题似乎是超链接引用随着公式移动到 D 列而发生变化。 Row()-4 尝试做一个 MATCH 公式； MATCH(B6,Sheet2!$B$2:$B$10,0) 这应该意味着超链接仍然指向 Sheet2 上的正确行。至于 F 列，如果您已经设置了执行 VLOOKUP 的公式，是否需要从 C 列复制值？
嗨汤姆，我可以让 HYPERLINK 功能与 MATCH 一起使用的唯一方法是使用以下内容：=HYPERLINK("#"&CELL("address",INDEX(Sheet2!B2:B9,MATCH(B6,Sheet2!B2:B9,0))),Sheet2!$A2) 但这仍然导致 A6-A11 被复制到 D6-D11 而不是单元格在 C 列中具有所需状态的 A 列中（我之前还没有弄清楚如何正确设置 Range.Copy，但我现在在代码中更新了这个，所以 VLOOKUP 仍然用于 C 列）谢谢@TomW

【解决方案2】：

在此处利用Case 声明。见下文。

Sub RangeCopyPaste()

Dim cell As Range
Dim NewRange As Range
Dim MyCount As Long
MyCount = 1

'--> Loop through each cell in column C
'--> Add each cell in column B with value "Ready for Testing" in column B to 

For Each cell In Worksheets("OverviewTest").Range("C6:C56")

    Select Case cell.Value 

        Case is = "Ready for Testing", "Build in Prod", "In Progress", "Awaiting CAB Approval"

            If MyCount = 1 Then 
                Set NewRange = cell.Offset(0, -1)
            Else
               Set NewRange = Application.Union(NewRange, cell.Offset(0, -1))
            End If

            MyCount = MyCount + 1

    End Select

Next cell

'--> Copy NewRange from inactive sheet into active sheet
NewRange.Copy Destination:=ActiveSheet.Range("D6")


End Sub

【讨论】：