数据导入求助

760636412

如附件有代码： 数据导入.zip (103.9 KB, 下载次数: 6)

2025-3-14 14:19 上传

点击文件名下载附件

如图：我想要达成，选中那个数据表，导入数据时导入相应的数据工表中，并关闭选中数据的表，用一段代码可以完成吗？我能想到，是分四段代码能达成想要的 ，救指导下，谢谢老师们，
还有一问题，以月份为判断，数据表已存在已有的月份，再导入不可以导入了，但可以替换更新，谢谢大神给点意见和指导。

chxw68

导入跟查询有关系吗？导入只是把选中的工作簿文件比如[库存数据.xslx]中的数据导入到[导入数据.xlsm]文件中对应的工作表中？

760636412

chxw68 发表于 2025-3-14 14:46
导入跟查询有关系吗？导入只是把选中的工作簿文件比如[库存数据.xslx]中的数据导入到[导入数据.xlsm]文件中 ...

只是导入数据，旁边不是有个选项按钮，就是选中那个，数据导入相应的数据表中，不用弄查询的，

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim km$
   
4.     Dim arr, brr
   
5.     Dim wb As Workbook
   
6.     Dim ws As Worksheet
   
7.     Dim d As Object
   
8.     Dim rng As Range
   
9.     Set d = CreateObject("scripting.dictionary")
   
10.     Application.ScreenUpdating = False
    
11.     Application.DisplayAlerts = False
    
12.     With ThisWorkbook.Worksheets("查询")
    
13.         For i = 1 To 4
    
14.             If .Shapes("OptionButton" & i).OLEFormat.Object.Object.Value = True Then
    
15.                 km = .Shapes("OptionButton" & i).OLEFormat.Object.Object.Caption
    
16.             End If
    
17.         Next
    
18.         If km <> empth Then
    
19.             mypath = ThisWorkbook.Path & ""
    
20.             myname = km & ".xlsx"
    
21.             If Dir(mypath & myname) = "" Then
    
22.                 MsgBox myapth & myname & "不存在！"
    
23.                 Exit Sub
    
24.             End If
    
25.             Set wb = GetObject(mypath & myname)
    
26.             With wb
    
27.                 With .Worksheets(1)
    
28.                     .AutoFilterMode = False
    
29.                     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
30.                     c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    
31.                     brr = .Range("a2").Resize(r - 1, c)
    
32.                     For i = 1 To UBound(brr)
    
33.                         d(brr(i, 2)) = Empty
    
34.                     Next
    
35.                 End With
    
36.                 .Close False
    
37.             End With
    
38.         End If
    
39.     End With
    
40.     With ThisWorkbook
    
41.         With .Worksheets(km)
    
42.             r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
43.             c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    
44.             If r = 1 Then
    
45.                 .Range("a2").Resize(UBound(brr), UBound(brr, 2)) = brr
    
46.             Else
    
47.                 arr = .Range("a1").Resize(r, c)
    
48.                 Set rng = .Rows(r + 1)
    
49.                 For i = 2 To UBound(arr)
    
50.                     If d.exists(arr(i, 2)) Then
    
51.                         Set rng = Union(rng, .Rows(i))
    
52.                     End If
    
53.                 Next
    
54.                 rng.Delete
    
55.                 r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
56.                 .Cells(r + 1, 1).Resize(UBound(brr), UBound(brr, 2)) = brr
    
57.             End If
    
58.         End With
    
59.     End With
    
60.     Application.ScreenUpdating = True
    
61.     MsgBox "数据导入完毕！"
    
62. End Sub
    

复制代码

chxw68

猜测着写了[数据导入]代码。