Question

我正在使用从excel工作簿中提取数据的在线代码。但是，它只在我想要添加数据时复制和粘贴数据。让我们说我要复制的单元格包含数字＆＃34; 4＆＃34;我想把它粘贴到已经包含数字5的单元格中。而不是显示＆＃34; 4＆＃34;，我希望它显示＆＃34; 9＆＃34;。我假设下面的行是我需要更改但无法弄清楚要将其更改为

我正在使用一系列细胞。

行：

TargetRange.Cells(1, 1).CopyFromRecordset rsData

完整代码：

Option Explicit


Public Sub GetData(SourceFile As Variant, SourceSheet As String, _
               SourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean)

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 Macro;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

Answer 1

这不像使用带有ADO Recordset的SQL那样雄辩或快速，但它更容易实现。

Thread.sleep()

Answer 2

您可以使用以下内容一次查询所有工作表：

SELECT * FROM [Sheet1$AV253:DC258] IN 'C:\Book1.xls'[Excel 12.0;] UNION ALL
SELECT * FROM [Sheet1$AV253:DC258] IN 'C:\Book2.xls'[Excel 12.0;]

添加并粘贴Recordset对象VBA

2 个答案: