將包含特定值的單元格複製到另一列，跳過空白

Question

我有列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 

新腳本這裏Case聲明

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 

Answer 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 

Answer 2

利用。見下文。

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