如果满足条件/条件，则将数据复制到其他工作簿

Question

如果在此处多次提到此问题，则表示抱歉。我是vba excel的初学者，所以我只对如何开始代码有一个简单的了解。我正在使用Excel 2013.

我有2个不同的工作簿，主要和副本。 第1行至第4行将为空。 第5行是用于标题/标记它将为这两个工作簿提供的信息。

“主”工作簿将使用列A到DN来存储所有数据。

如果单元格包含“X” - 它会将列A复制到P，复制到工作簿“copy”。之后，它将继续到下一行以确定相同的事情。 如果单元格为空，它将继续下一行以确定相同的内容。 代码必须是动态的，因为每3个月会添加新信息，例如添加新行或从“X”变为空或从空变为“X”的标准。

这是我现在得到的代码。 它的工作原理，但由于有太多的列要检查，我被建议为此做另一个代码。

Sub copy() 
 
Dim lr As Long, lr2 As Long, r As Long 
 
lr = Sheets("main").Cells(Rows.Count, "A").End(xlUp).row 
 
lr2 = Sheets("copy").Cells(Rows.Count, "A").End(xlUp).row 
 
For r = lr To 2 Step -1 
 
    If range("Q" & r).Value = "X" Then 
 
     Rows(r).copy Destination:=Sheets("copy").range("A" & lr2 + 1) 
 
     lr2 = Sheets("copy").Cells(Rows.Count, "A").End(xlUp).row 
 
    End If 
 
Next r 
 
End Sub

Answer 1

对于您必须声明两个变量，工作簿和两个工作表变量来保存代码中的源和目标工作簿和工作表的参考。

根据您的要求调整以下代码。

我在代码中添加了注释，这将有助于您理解程序的流程。

此外，可以使用更多的错误处理来确保分别在源和目标工作簿中找到源和目标工作表。 如果需要，您也可以添加错误处理。

Option Explicit 

Sub CopyDatoToAnotherWorkbook() 
Dim srcWB As Workbook, destWB As Workbook  'Variables to hold the source and destination workbook 
Dim srcWS As Worksheet, destWS As Worksheet  'Variables to hold the source and destination worksheets 
Dim FilePath As String       'Variable to hold the full path of the destination workbook including it's name with extension 
Dim lr As Long, lr2 As Long, r As Long 

Application.ScreenUpdating = False 

Set srcWB = ThisWorkbook      'Setting the source workbook 
Set srcWS = srcWB.Sheets("main")    'Setting the source worksheet 

'Setting the FilePath of the destination workbook 
'The below line assumes that the destination file's name is MyFile.xlsx and it is saved at your desktop. Change the path as per your requirement 
FilePath = Environ("UserProfile") & "\Desktop\MyFile.xlsx" 

'Cheching if the destination file exists, it yes, proceed with the code else EXIT 
If Dir(FilePath) = "" Then 
    MsgBox "The file " & FilePath & " doesn't exist!", vbCritical, "File Not Found!" 
    Exit Sub 
End If 
'Finding the last row used in column A on source worksheet 
lr = srcWS.Cells(Rows.Count, "A").End(xlUp).Row 

'Opening the destination workbook and setting the source workbook 
Set destWB = Workbooks.Open(FilePath) 

'Setting the destination worksheet 
Set destWS = destWB.Sheets("copy") 

'Looping through rows on source worksheets 
For r = lr To 2 Step -1 
    'Finding the first empty row in column A on destination worksheet 
    lr2 = destWS.Cells(Rows.Count, "A").End(xlUp).Row + 1 

    If srcWS.Range("Q" & r).Value = "X" Then 
     srcWS.Rows(r).copy Destination:=destWS.Range("A" & lr2 + 1) 
    End If 
Next r 

'Closing the destination workbook 
destWB.Close True 
Application.CutCopyMode = False 
Application.ScreenUpdating = True 
End Sub