获取不打开工作薄数据

yfxfsj

ykcbf1100 发表于 2025-4-2 14:51
改一下吧。

谢谢老师的热心，可能我语言表达不准确。点“导入数据”按钮后，如下图： 这时“合并企业”表数据到了第18行，我再点一次“导入数据”，导出表里的11行数据还要再加入进来，这时“合并企业”表数据到了18+11=29行，再按一次按钮，就有29+11=40行数据，也就是在点“导入数据”按钮时，不能清空原来”合并企业“表的原来数据，而是在原有数据基础上一直累加下去。老师代码精简有效，我许多看不懂，不能的话自己来修改。

quqiyuan

参与一下，仅供参考，使用SQL方法。。。

ykcbf1100

yfxfsj 发表于 2025-4-2 15:20
谢谢老师的热心，可能我语言表达不准确。点“导入数据”按钮后，如下图：这时“合并企业”表数据到了第18 ...

现在就是递增式写入数据的，有问题吗？哦，取最大行的语句应该用第2列。我再改一下吧。

quqiyuan

代码如下。。。
Sub test()
    Dim arr(1 To 10000, 1 To 11)
    Dim wb As Workbook, sht As Worksheet, sh As Worksheet
    Set wb = ThisWorkbook
    Set sht = wb.Sheets("合并企业")
    r = sht.Cells(Rows.Count, 2).End(3).Row
    Set cnn = New ADODB.Connection
    cnn.Open "provider=microsoft.Ace.oledb.12.0;extended properties=excel 12.0;data source=" & ThisWorkbook.Path & "\导出表.xlsx"
    Sql = "select * from [导出表$] "
    Set rs = New ADODB.Recordset
    rs.Open Sql, cnn, adOpenKeyset, adLockOptimistic
    For i = 1 To CLng(rs.RecordCount)
        n = n + 1
        arr(n, 1) = rs.Fields(2).Value
        arr(n, 2) = rs.Fields(0).Value
        arr(n, 3) = rs.Fields(3).Value
        arr(n, 6) = rs.Fields(4).Value
        arr(n, 7) = rs.Fields(5).Value
        arr(n, 10) = rs.Fields(6).Value
        arr(n, 11) = rs.Fields(7).Value
        rs.MoveNext
    Next i
    sht.Cells(r + 1, 2).Resize(n, 11) = arr
    Beep
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
End Sub
   

yfxfsj

ykcbf1100 发表于 2025-4-2 15:24
现在就是递增式写入数据的，有问题吗？哦，取最大行的语句应该用第2列。我再改一下吧。

这个表头也给我清空了

yfxfsj

quqiyuan 发表于 2025-4-2 15:23
参与一下，仅供参考，使用SQL方法。。。

正解，谢谢老师帮助！

yfxfsj

ykcbf1100 发表于 2025-4-2 15:24
现在就是递增式写入数据的，有问题吗？哦，取最大行的语句应该用第2列。我再改一下吧。

完美解决，再次感谢老师。

ykcbf1100

yfxfsj 发表于 2025-4-2 15:27
这个表头也给我清空了

标题行复制回去就行了。

gwjkkkkk

Option Explicit
Sub test()
    Dim ar, br, cr, i&, j&, r&, strFileName$, strPath$
   
   
    strPath = ThisWorkbook.Path & "\"
    strFileName = strPath & "导出表.xlsx"
   
    If Dir(strFileName) = "" Then MsgBox "未找到数据": Exit Sub
   
    Application.ScreenUpdating = False
   
    cr = [{1,3;2,1;3,4;6,5;7,6;10,7;11,8}]
    ReDim ar(1 To 10 ^ 4, 1 To 11)
   
    With GetObject(strFileName)
        br = .Worksheets(1).[A1].CurrentRegion.Value
        For i = 2 To UBound(br)
            r = r + 1
            For j = 1 To UBound(cr)
                ar(r, cr(j, 1)) = br(i, cr(j, 2))
            Next j
        Next i
        .Close False
    End With
   
    r = Cells(Rows.Count, "B").End(xlUp).Row + 1
    Cells(r, 2).Resize(UBound(br) - 1, UBound(ar, 2)) = ar
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk