Question

我有VBA宏，可在打开csv文件后将数据从工作簿中的各个选项卡复制到csv文件。这部分工作正常。但是，我想检查csv文件是否尚未打开，然后将其打开并粘贴数据。如果已经打开，则只需粘贴数据。

Sub BU_Macro()



    Dim LR As Long, X As Long
    ThisWorkbook.Activate


    With Sheets("Report Group")

        LR = .Range("A" & .Rows.Count).End(xlUp).Row
        MyCopyRange = Array("A4:A" & LR, "B4:B" & LR, "C4:C" & LR, "D4:D" & LR) 'Put ranges in an array
        MyPasteRange = Array("A1", "B1", "C1", "D1")

        Dim myData As Workbook
        'open target csv file if not already opened
        If CheckFileIsOpen("test.csv") = False Then
            Set myData = Workbooks.Open(strFilePath & "test.csv")

        End If


        Worksheets("test").Select
        Sheets("test").UsedRange.Clear

        If LR > 1 Then
            j = 0
            For X = LBound(MyCopyRange) To UBound(MyCopyRange) 'Loop the array copying and pasting based on element in the array
                .Range(MyCopyRange(j)).Copy
                Sheets("test").Range(MyPasteRange(j)).PasteSpecial xlPasteValuesAndNumberFormats 'xlPasteValues
                j = j + 1
            Next

        Else
            Range("A1") = "No Data Found"
        End If

    End With

End Sub
Function CheckFileIsOpen(chkfile As String) As Boolean

    On Error Resume Next

    CheckFileIsOpen = (Workbooks(chkfile).Name = chkfile)

    On Error GoTo 0

End Function

如果文件已关闭，则会将其打开并粘贴日期，但是如果文件已打开，则会出现错误：

Run-time error '9':
Subscript out of range
on line-
Worksheets("test").Select

我想，我无法直接将代码集中在test.csv上

Answer 1

稍作修改以添加完整的工作簿/工作表限定符，并避免激活/选择

Sub BU_Macro()

    Dim LR As Long, X As Long, MyCopyRange, MyPasteRange, strFilePath
    Dim wb, myData As Workbook, shtPaste As Worksheet

    Set wb = ThisWorkbook

     'Put ranges in an array
    MyPasteRange = Array("A1", "B1", "C1", "D1")

    'open target csv file if not already opened
    If CheckFileIsOpen("test.csv") = False Then
        Set myData = Workbooks.Open(strFilePath & "test.csv")
    Else
        Set myData = Workbooks("test.csv")
    End If

    Set shtPaste = myData.Sheets("test")
    shtPaste.UsedRange.Clear

    With wb.Sheets("Report Group")

        LR = .Range("A" & .Rows.Count).End(xlUp).Row

        If LR > 1 Then
            MyCopyRange = Array("A4:A" & LR, "B4:B" & LR, "C4:C" & LR, "D4:D" & LR)
            'Loop the array copying and pasting based on element in the array
            For X = LBound(MyCopyRange) To UBound(MyCopyRange)
                .Range(MyCopyRange(X)).Copy
                shtPaste.Range(MyPasteRange(X)).PasteSpecial _
                           xlPasteValuesAndNumberFormats 'xlPasteValues
            Next
        Else
            shtPaste.Range("A1") = "No Data Found"
        End If

    End With

End Sub

Excel VBA如果文件已关闭，则打开并粘贴，否则仅粘贴数据

1 个答案: