ByVal/ByRef 复制数据 [VBA]

Question

[已找到答案 - 问题不在于 Sourcerange。显然这是因为我没有在 Extractdata1 中为每个输入 WB 指示“.xlsx”。不知何故，这导致代码为每个输出单元生成相同的值。在为每个输入 WB 添加 .xlsx 后，我能够获得不同的值。]

我这里有一段代码，我正在尝试使用 ByVal。我找不到很多资源来学习 ByVal 写作以达到我的目的（复制粘贴数据），所以我很苦恼。

目的：从3个不同的输入WB的H17单元格中提取数据，分别粘贴到输出WB的A1、A2、A3中。

问题：目前，以下代码在 A1、A2 和 A3 中给出了相同的值...并且该值等于最后打开的输入 WB（而不是来自 3 个不同输入 WB 的 3 个值）。

我也尝试过 ByRef，但没有解决问题。

提前致谢。

Sub Extractdata()
    Dim FromPath As String
    Dim FromSheetName As String
    Dim TargetRange As Range

    With Workbooks.Open("C:\Users\[OutputWB].xlsm").Worksheets("Sheet1")
        Extractdata1 "C:\Users\[InputWB1]", "[InputSheet]", .Range("A1")
        Extractdata1 "C:\Users\[InputWB2]", "[InputSheet]", .Range("A2")
        Extractdata1 "C:\Users\[InputWB3]", "[InputSheet]", .Range("A3")
    End With
End Sub


Sub Extractdata1(ByVal FromPath As String, ByVal FromSheetName As String, ByVal TargetRange As Range)
    With Workbooks.Open(FromPath)
        With .Worksheets(FromSheetName)
            Set SourceRange = .Range("H17")
            TargetRange.Value = SourceRange.Value    
        End With    
    End With
End Sub

Answer 1

如果您想要做的是 link 将一个单元格的值与另一个工作簿中的值进行比较，则有一种更简单的方法：将以下公式粘贴到单元格 A1、A2 和 A3 中OutputWB.xlsm 无需代码即可完成作业。

='C:\Users\[InputWB1.xlsx]Sheet1'!$H
='C:\Users\[InputWB2.xlsx]Sheet1'!$H
='C:\Users\[InputWB3.xlsx]Sheet1'!$H

如果不能满足您的需要，请查看以下修改后的代码。我删除了导致文件未找到错误的方括号。我还将文件路径放入一个变量中，以便更容易在不同的环境中进行测试。我强烈建议在最后添加一个关闭文件指令，除非你想在最后保持所有工作簿打开。

Sub Extractdata()

Dim FromPath As String
Dim FromSheetName As String
Dim TargetRange As Range
Dim FilePath As String
FilePath = "C:\Users\"

With Workbooks.Open(FilePath & "OutputWB.xlsm").Worksheets("Sheet1")

Extractdata1 FilePath & "InputWB1", "InputSheet", .Range("A1")
Extractdata1 FilePath & "InputWB2", "InputSheet", .Range("A2")
Extractdata1 FilePath & "InputWB3", "InputSheet", .Range("A3")

End With

End Sub


Sub Extractdata1(ByVal FromPath As String, ByVal FromSheetName As String, ByVal TargetRange As Range)
    With Workbooks.Open(FromPath)
        With .Worksheets(FromSheetName)
Debug.Print (FromPath)
Set SourceRange = .Range("H17")
TargetRange.Value = SourceRange.Value
    
        End With
    
    End With
End Sub

Answer 2

从不同的文件复制相同的单元格

这是我这边的作品。也许您可以发现相关差异。
ScreenUpdating与它无关，它在源文件未关闭时也有效。

Option Explicit

Sub Extractdata()

    Const FolderPath As String = "C:\Test\"
    
    Application.ScreenUpdating = False
    
    With Workbooks.Open(FolderPath & "Output.xlsm").Worksheets("Sheet1")
        Extractdata1 FolderPath & "Test1.xlsx", "Sheet1", .Range("A1")
        Extractdata1 FolderPath & "Test2.xlsx", "Sheet1", .Range("A2")
        Extractdata1 FolderPath & "Test3.xlsx", "Sheet1", .Range("A3")
        '.Close SaveChanges:=True
    End With
    
    Application.ScreenUpdating = True

End Sub

Sub Extractdata1( _
        ByVal FromPath As String, _
        ByVal FromSheetName As String, _
        ByVal TargetRange As Range)
    
    With Workbooks.Open(FromPath)
        With .Worksheets(FromSheetName)
            TargetRange.Value = .Range("H17").Value
        End With
        .Close SaveChanges:=False
    End With

End Sub

ByVal/ByRef 复制数据 [VBA]

ByVal/ByRef to copy data [VBA]

excel

vba

byref

byval

从不同的文件复制相同的单元格