有条件复制不相邻的列的VBA代码

项目主pipe

在使用VBA的MS Excel中，我想在同一工作簿中的工作表之间进行有条件的复制。 根据所附的图片，我在工作表“主”上有一个项目主表。 对于列I（缺陷）中的“是”的所有项目，我想复制列A（工程包发行date），B（项目编号），E（城市）和H（合同价值）到另一个工作表“缺陷”，在同一个工作簿。 你能否提供一个编码，可以：a）折叠所有行，使“缺陷”工作表中没有空行; 和b）保留所有行，如果“缺陷”列有“否”，则“主”工作表中的相关行在可能的情况下作为空白行复制到“缺陷”工作表中。 请帮助我编写代码 – 我有macros的基本知识，并在学习如何编码的过程。 谢谢，关心，CK

Answer 1

试试这个让你开始。 另外，在将来，请张贴您拥有的代码，得到的错误或您遇到的具体问题，而不是要求代码解决问题。 还有很多其他的海报，如果你没有表明自己已经提出了一些解决scheme，他们只会投票给你，或者删除你的post。

Sub CopyValues() 'Declare variables 'Declare sheet variables Dim Masterws as Worksheet Dim Defectws as worksheet 'Declare counter variables Dim I as Integer Dim n as Integer 'Set value of sheet variables Set Masterws=ThisWorkbook.Sheets("Master") Set Defectws=ThisWorkbook.Sheets("Defects") 'Set value of counter to track first available row on Defects sheet n=1 'Start a For loop to check each row on Master sheet, starting with row 2 For I = 2 to WorksheetFunction.CountA(Masterws.Columns.EntireColumn(1)) 'If the cells in row I, column I have a value of, "Yes," then execute some code. If not, continue on. If Cells(I, "I").value= "Yes" Then 'Set the value of cells in row n of the Defects sheet to the corresponding values of row I in the Master sheet. If n is replaced with I, then the value of cells in row I on Defects will be set to the values of Row I on Master, leaving blank rows where no, "Yes," was found because no copying took place. Defectws.Cells(n,"A").Value=Masterws.cells(I,"A") Defectws.Cells(n,"B").Value=Masterws.cells(I,"B") Defectws.Cells(n,"C").Value=Masterws.cells(I,"E") Defectws.Cells(n,"D").Value=Masterws.cells(I,"H") 'Add 1 to the n counter. The next time a row is found in the Master sheet with, "Yes," it will be written to the next available row down on the Defects sheet. n=n+1 End If 'End of the For loop. Move on to the next row on Master sheet Next End Sub 

Answer 2

@ asp8811感谢代码，它运作良好。 对不起，我没有把早些时候我已经 – 我是新来的堆栈溢出，新的编码 – 将始终与我的代码前进。 下面是我到目前为止 – 将您的代码和答案结合到我之前问过的另一个问题。 你的代码工作得很好，让我能够select我select的列，不像我下面的 – 它打印A和H之间的所有列。我的挑战是，我想保留行（作为空行），如果有缺陷列中的“否” – 这是我下面的内容，但是我也想报告那些不相邻的列，并且能够select像你一样的列。

 Sub CopyValues() Dim Masterws As Worksheet Dim Defectws As Worksheet Dim I As Integer Dim n As Integer Set Masterws = ThisWorkbook.Sheets("Master") Set Defectws = ThisWorkbook.Sheets("Defects") n = 1 For I = 2 To WorksheetFunction.CountA(Masterws.Columns.EntireColumn(1)) If (Masterws.Range("J" & I) = "Yes") Then Masterws.Range("A" & I & ":H" & I).Copy Destination:=Worksheets("Defects").Range("A" & I) n = n + 1 End If Next End Sub