修改VBA代码移除FiletoOpen功能，适配已打开的源工作簿

要让代码直接使用已打开的工作簿，只需移除文件选择和打开逻辑，改为直接引用已打开的工作簿实例。以下是两种常用修改方案：

方案一：直接指定目标工作簿名称 #

如果已知源工作簿的固定名称（比如"源数据.xlsx"），可以直接按名称引用：

Sub GetJEData()
    
    Dim wb As Workbook, pasteRow As Range
    
    ' 直接引用已打开的工作簿，替换为你的源工作簿名称
    On Error Resume Next ' 防止工作簿未打开时报错
    Set wb = Application.Workbooks("源数据.xlsx")
    On Error GoTo 0
    
    ' 检查工作簿是否存在
    If wb Is Nothing Then
        MsgBox "指定的工作簿未打开，请先打开源工作簿！", vbExclamation
        Exit Sub
    End If
    
    Set pasteRow = ThisWorkbook.Worksheets("Journal Entry").Rows(14) ' 粘贴目标行
    
    Application.ScreenUpdating = False
    With wb.Worksheets("Journal Entry")
        DoCopy .Range("C18"), pasteRow.Columns("E"), True
        DoCopy .Range("H18"), pasteRow.Columns("L"), True
        DoCopy .Range("K18"), pasteRow.Columns("J"), True
        DoCopy .Range("S18"), pasteRow.Columns("AB"), True
        DoCopy .Range("O18"), pasteRow.Columns("Z"), True
    End With
    ' 其他工作表的复制逻辑
    With wb.Worksheets("Other sheet")
        DoCopy .Range("A16"), pasteRow.Columns("A"), True
        DoCopy .Range("B16"), pasteRow.Columns("B"), True
    End With
    
    Application.ScreenUpdating = True ' 恢复屏幕更新
End Sub

' 复制指定列从起始单元格到最后有数据的单元格，粘贴到目标位置
' ValuesOnly参数为True时仅复制值
Sub DoCopy(srcStart As Range, destCell As Range, Optional ValuesOnly As Boolean = False)
    Dim cLast As Range
    With srcStart.Worksheet
        Set cLast = .Cells(.Rows.Count, srcStart.Column).End(xlUp) ' 获取列最后一个有数据的单元格
        If cLast.Row >= srcStart.Row Then ' 检查是否有数据可复制
            If ValuesOnly Then ' 仅复制值
                Dim arr As Variant
                arr = .Range(srcStart, cLast).Value
                destCell.Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
            Else ' 复制格式和值
                .Range(srcStart, cLast).Copy destCell
            End If
        End If
    End With
End Sub

方案二：从已打开的工作簿中选择（通用灵活） #

如果源工作簿名称不固定，可以添加对话框从当前打开的工作簿中选择：

Sub GetJEData()
    
    Dim wb As Workbook, pasteRow As Range
    Dim wbName As String
    
    ' 弹出选择框让用户选已打开的工作簿
    wbName = Application.InputBox("请输入源工作簿的名称（或从下方列表选择）：" & vbCrLf & _
                                 "已打开的工作簿：" & vbCrLf & Join(GetOpenWorkbookNames(), vbCrLf), _
                                 "选择源工作簿", Type:=2)
    If wbName = "" Then Exit Sub ' 用户取消选择
    
    ' 查找对应工作簿
    On Error Resume Next
    Set wb = Application.Workbooks(wbName)
    On Error GoTo 0
    
    If wb Is Nothing Then
        MsgBox "未找到名为'" & wbName & "'的工作簿，请确认名称正确！", vbExclamation
        Exit Sub
    End If
    
    Set pasteRow = ThisWorkbook.Worksheets("Journal Entry").Rows(14) ' 粘贴目标行
    
    Application.ScreenUpdating = False
    With wb.Worksheets("Journal Entry")
        DoCopy .Range("C18"), pasteRow.Columns("E"), True
        DoCopy .Range("H18"), pasteRow.Columns("L"), True
        DoCopy .Range("K18"), pasteRow.Columns("J"), True
        DoCopy .Range("S18"), pasteRow.Columns("AB"), True
        DoCopy .Range("O18"), pasteRow.Columns("Z"), True
    End With
    ' 其他工作表的复制逻辑
    With wb.Worksheets("Other sheet")
        DoCopy .Range("A16"), pasteRow.Columns("A"), True
        DoCopy .Range("B16"), pasteRow.Columns("B"), True
    End With
    
    Application.ScreenUpdating = True ' 恢复屏幕更新
End Sub

' 获取所有已打开工作簿的名称，用于选择框提示
Function GetOpenWorkbookNames() As Variant
    Dim names() As String, i As Integer
    ReDim names(1 To Application.Workbooks.Count)
    
    For i = 1 To Application.Workbooks.Count
        names(i) = Application.Workbooks(i).Name
    Next i
    
    GetOpenWorkbookNames = names
End Function

' 复制指定列从起始单元格到最后有数据的单元格，粘贴到目标位置
' ValuesOnly参数为True时仅复制值
Sub DoCopy(srcStart As Range, destCell As Range, Optional ValuesOnly As Boolean = False)
    Dim cLast As Range
    With srcStart.Worksheet
        Set cLast = .Cells(.Rows.Count, srcStart.Column).End(xlUp) ' 获取列最后一个有数据的单元格
        If cLast.Row >= srcStart.Row Then ' 检查是否有数据可复制
            If ValuesOnly Then ' 仅复制值
                Dim arr As Variant
                arr = .Range(srcStart, cLast).Value
                destCell.Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
            Else ' 复制格式和值
                .Range(srcStart, cLast).Copy destCell
            End If
        End If
    End With
End Sub

修改关键点说明 #

1. 移除文件打开逻辑：删掉filetoOpen变量、GetOpenFilename和Workbooks.Open相关代码，避免重复打开文件。
2. 直接引用已打开工作簿：通过工作簿名称定位实例，或提供选择界面提升灵活性。
3. 增加错误检查：添加工作簿不存在时的提示，避免代码崩溃。
4. 恢复屏幕更新：在代码末尾重新启用ScreenUpdating，避免Excel界面卡顿。

内容的提问来源于stack exchange，提问作者Fred Blair