添加并粘贴logging集对象VBA
我正在使用从Excel工作簿提取数据的在线代码。 但是，它只复制和粘贴数据，而我想要它添加数据。 比方说，我想要复制的单元格包含数字“4”，我想将其粘贴到已包含数字5的单元格中。而不是显示“4”，我希望它显示“9”。 我假设下面的行是我需要改变，但不知道要改变它
我正在与一系列的细胞工作。
线：
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
这不像在ADO Recordset中使用SQL那么有说服力或快速，但实现起来要容易得多。
Public Sub GetData(SourceFile As Variant, SourceSheet As String, SourceRange As String, TargetRange As Range) Application.ScreenUpdating = False Dim CloseFile As Boolean Dim wb As Workbook On Error Resume Next Set wb = Workbooks(SourceFile) On Error GoTo 0 If wb Is Nothing Then CloseFile = True Set wb = Workbooks.Open(Filename:=SourceFile, ReadOnly:=True) End If With wb With .Worksheets(SourceSheet) .Range(SourceRange).Copy TargetRange.PasteSpecial Paste:=xlPasteAll, Operation:=xlAdd, SkipBlanks:=False, Transpose:=False End With If CloseFile Then .Close SaveChanges:=False End With Application.ScreenUpdating = True End Sub
您可以使用类似的方式一次查询所有表单：
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;]