给定多个条件的 Excel VBA 从一张工作表复制到其他工作簿答案

【问题标题】：Excel VBA Copy from one sheet to other workbook given multiple criteria给定多个条件的 Excel VBA 从一张工作表复制到其他工作簿
【发布时间】：2017-11-02 19:08:24
【问题描述】：

我知道这个问题早已存在，但我正在尝试根据多个条件将 Excel 文件中的数据复制到另一个文件中。

目标称为“Test.xlsm”，源称为“Data.xlsx” 这个想法是让代码识别列 A 上具有文本 (1,3,D) 的行，并将整行复制到目标 Test.xlsm 上的 Sheet1

Test.xlsm 的第一行有一个标题，因此在将数据复制到该工作表时必须单独保留它。

默认情况下，这两个文件在名为“Sheet1”的工作表上都有目标和源信息。

我找到了这段代码，但我无法调整它以使用不同的工作表作为源代码，尽管任何可以达到目标的代码都可以。

Sub Copy()
Dim lr As Long, lr2 As Long, r As Long, ws1 As Worksheet, ws2 As Worksheet, n As Long
Application.ScreenUpdating = False
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
n = 1
lr = ws1.Cells(Rows.Count, "A").End(xlUp).Row
lr2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
    For r = 2 To lr
        If Range("A" & r).Value = "1" Or Range("A" & r).Value = "3" Or Range("A" & r).Value = "D" Then
            Rows(r).Copy Destination:=ws2.Range("A" & n + 1)
            n = ws2.Cells(Rows.Count, "A").End(xlUp).Row
        End If
    Next r
Application.ScreenUpdating = True
End Sub

【问题讨论】：

您只需要指定工作表所在的工作簿吗？例如。 Set ws1 = Application.Workbooks("Data").Sheets("Sheet1")
下标超出范围，尝试为两者定义路径，然后仅为信息源定义 Set ws1 = Sheets("Sheet1") Set ws2 = Application.Workbooks("Data.xlsx") .Sheets("Sheet1")
当我打开两个文件时，它会复制，但它会从我打开的任何工作簿上的任何工作表中复制，而我单击运行它时，无论我是否说明了要使用哪个工作表
是的，你肯定需要打开两本书才能开始它，否则你需要一个稍微不同的方法。它从您打开的任何工作表中复制的原因是因为您还需要为范围指定工作表，例如If Range("A" & r).Value 应该变成 If ws1.Range("A" & r).value
我将根据以上两点在下面发布完整的代码编辑

标签： vba excel

【解决方案1】：

您还需要使用工作簿，因为您使用的是单独的工作簿，然后按照您提供的示例设置工作表。

例如：

Dim wkbk1 as Workbook, wkbk2 as Workbook, ws1 as WorkSheet, ws2 as Worksheet
Set wkbk1 = Workbooks.open("C:\path\to\Data.xlsx")
Set wkbk2 = Workbooks.open("C:\path\to\Test.xlsm")

Set ws1 = wkbk1.Sheets("Sheet1")
Set ws2 = wkbk2.Sheets("Sheet1")

您可以从那里使用和修改您拥有的代码。

编辑：包括 OP 的工作簿和工作表名称。

【讨论】：

我不太擅长这个，在将代码添加到它并尝试运行它之后，它说“下标超出范围”，当我选择 DEBUG 时，给出错误的行是 Set wkbk1 和 Set wkbk2.
尝试为路径输入确切的路径。
我试过了，它不工作 Dim lr As Long, lr2 As Long, r As Long, n As Long Dim wkbk1 As Workbook, wkbk2 As Workbook, ws1 As Worksheet, ws2 As Worksheet Application.ScreenUpdating =错误 Set wkbk1 = Workbooks("C:\Users\murilale\Desktop\Programming\Macros\Test\Test Beta.xlsm") 设置 wkbk2 = Workbooks("C:\Users\murilale\Desktop\Programming\Macros\Test\Data .xlsx") 设置 ws1 = wkbk1.Sheets("Sheet1") 设置 ws2 = wkbk2.Sheets("Sheet1")
检查我的编辑，尝试使用 Workbooks.Open("path to book")
已更正，现在打开 Test.xlsm 后它什么也没做，我也尝试使用 Set wkbk1 = ThisWorkbook 但它不起作用

【解决方案2】：

尝试此编辑或记下我根据 cmets 中的点进行编辑的位置 - 我认为这应该做得很好！

Sub CopyThings()
Dim lr As Long, lr2 As Long, r As Long, ws1 As Worksheet, ws2 As Worksheet, n As Long
Application.ScreenUpdating = False
Set ws1 = Application.Workbooks("Data").Worksheets("Sheet1")
Set ws2 = Application.Workbooks("Test").WorkSheets("Sheet1")
n = 1
lr = ws1.Cells(Rows.Count, "A").End(xlUp).Row
lr2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
    For r = 2 To lr
        If ws1.Range("A" & r).Value = "1" Or ws1.Range("A" & r).Value = "3" Or ws1.Range("A" & r).Value = "D" Then
            ws1.Rows(r).Copy Destination:=ws2.Range("A" & n + 1)
            n = ws2.Cells(Rows.Count, "A").End(xlUp).Row
        End If
    Next r
Application.ScreenUpdating = True
End Sub

【讨论】：