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

如果满足条件/条件，则将数据复制到另一个工作簿

1 个答案: