Question

我一直在处理我刚刚发布的最近发布的帖子，但显然，代码中的条件仍然没有成功。

我想将数据从某个源工作簿复制到我工作的当前打开的工作簿，但仅在条件下，如果我当前工作簿中定义的名称与第N列中的变量的前18个字符匹配：N我希望从中复制数据的源工作簿。

我使用了脑筋的帮助，帮助我修改了这个条件 - 它是在星星线之后开始的，然而，它仍然不起作用。没有条件匹配定义的名称（在我当前的工作簿中）与N：N列中的变量（在SourceWorkbook中），代码工作正常 - 所以我在构造条件时遇到问题。

我添加了一行说：ActiveArray.Close，在流程结束时关闭源工作簿，然而，它返回的唯一结果是打开源工作簿，这就是全部。根本不执行匹配和复制，并且不会发生错误。知道为什么会这样吗？我感谢任何回应。

    Sub Copy_Data()

            Dim ActiveArray As Variant
            Dim SourceWBpath As Variant
            Dim i As Long
            endRow = 1003
            Const l_MyDefinedName As String = "MyDefinedName"
            Const s_ColumnToMatch As String = "N:N"                'The column in the Source Workbook to be match with My defined name

            Application.ScreenUpdating = False

            Set ActiveArray = ActiveWorkbook
            Set SourceWBpath= ThisWorkbook.Worksheets("Test").Range("E1")      'Cell with path to the Source Workbook
            Set SourceWB = Workbooks.Open(SourceWBpath)
            Set MyWorkbook = ThisWorkbook.Worksheets("Test")

         '**************************Copy Workbook content to this sheet****************************************************
     With SourceWB
      Dim i As Long
      endRow = 1003
      For i = 2 To endRow
        Dim rngFound As Range
        On Error Resume Next
        Set rngFound =SourceWB.Worksheets("Sheet1").Range(s_ColumnToMatch).Find(What:=l_MyDefinedName & "*", LookAt:=xlWhole)
      Next i
        On Error GoTo 0
            If Not rngFound Is Nothing Then
                rngFound.Parent.Range("A2:Y1900").Copy
                ActiveArray.Sheets("Test").Range("A5").PasteSpecial xlPasteValues
                Application.CutCopyMode = False
                ActiveWorkbook.Close

                End If

        End With
        End Sub

Answer 1

也许就是这样。

Sub GetData_Example1()
' It will copy the Header row also (the last two arguments are True)
' Change the last argument to False if you not want to copy the header row
    GetData ThisWorkbook.Path & "\test.xls", "Sheet1", _
            "A1:C5", Sheets("Sheet1").Range("A1"), True, True
End Sub

Option Explicit


Public Sub GetData(SourceFile As Variant, SourceSheet As String, _
                   SourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean)
' 30-Dec-2007, working in Excel 2000-2007
    Dim rsCon As Object
    Dim rsData As Object
    Dim szConnect As String
    Dim szSQL As String
    Dim lCount As Long

    ' Create the connection string.
    If Header = False Then
        If Val(Application.Version) < 12 Then
            szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 8.0;HDR=No"";"
        Else
            szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 12.0;HDR=No"";"
        End If
    Else
        If Val(Application.Version) < 12 Then
            szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 8.0;HDR=Yes"";"
        Else
            szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 12.0;HDR=Yes"";"
        End If
    End If

    If SourceSheet = "" Then
        ' workbook level name
        szSQL = "SELECT * FROM " & SourceRange$ & ";"
    Else
        ' worksheet level name or range
        szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & SourceRange$ & "];"
    End If

    On Error GoTo SomethingWrong

    Set rsCon = CreateObject("ADODB.Connection")
    Set rsData = CreateObject("ADODB.Recordset")

    rsCon.Open szConnect
    rsData.Open szSQL, rsCon, 0, 1, 1

    ' Check to make sure we received data and copy the data
    If Not rsData.EOF Then

        If Header = False Then
            TargetRange.Cells(1, 1).CopyFromRecordset rsData
        Else
            'Add the header cell in each column if the last argument is True
            If UseHeaderRow Then
                For lCount = 0 To rsData.Fields.Count - 1
                    TargetRange.Cells(1, 1 + lCount).Value = _
                    rsData.Fields(lCount).Name
                Next lCount
                TargetRange.Cells(2, 1).CopyFromRecordset rsData
            Else
                TargetRange.Cells(1, 1).CopyFromRecordset rsData
            End If
        End If

    Else
        MsgBox "No records returned from : " & SourceFile, vbCritical
    End If

    ' Clean up our Recordset object.
    rsData.Close
    Set rsData = Nothing
    rsCon.Close
    Set rsCon = Nothing
    Exit Sub

SomethingWrong:
    MsgBox "The file name, Sheet name or Range is invalid of : " & SourceFile, _
           vbExclamation, "Error"
    On Error GoTo 0

End Sub

Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function


Function Array_Sort(ArrayList As Variant) As Variant
    Dim aCnt As Integer, bCnt As Integer
    Dim tempStr As String

    For aCnt = LBound(ArrayList) To UBound(ArrayList) - 1
        For bCnt = aCnt + 1 To UBound(ArrayList)
            If ArrayList(aCnt) > ArrayList(bCnt) Then
                tempStr = ArrayList(bCnt)
                ArrayList(bCnt) = ArrayList(aCnt)
                ArrayList(aCnt) = tempStr
            End If
        Next bCnt
    Next aCnt
    Array_Sort = ArrayList
End Function

根据匹配条件在工作簿之间复制数据（无需打开源）

1 个答案: