能否帮忙改进一下代码？

vbahappy

在论坛看到一指禅老师的跨工作表导入数据的代码，感觉挺实用的，但这个代码只能实现全表导入，

我想能否可以修改一下，实现原表已经存在的不导入，只导入新增不重复的部分呢？
sample.rar (19.19 KB, 下载次数: 17)

2024-6-16 23:21 上传

点击文件名下载附件

Sub 导入数据()
    Dim p$, f$, Wb As Workbook, Arr
    Dim aa As String, Falg As Boolean
    aa = InputBox("请输入文件名：", "导入数据", 36)
    If StrPtr(aa) <> 0 Then
        p = ThisWorkbook.Path
        f = Dir(p & "\" & aa & ".xls*")
        Do While f <> ""
            Set Wb = Workbooks.Open(p & "\" & f)
            Arr = Wb.Sheets(1).Range("A2:h40").Value
            Wb.Close False
            f = Dir
            Falg = True
        Loop
        If Falg Then
            Application.ScreenUpdating = False
            Sheet1.Range("A3:h65536").ClearContents
            Sheet1.Range("A3").Resize(UBound(Arr), UBound(Arr, 2)) = Arr
            Application.ScreenUpdating = True
        Else
            MsgBox "没有找到文件名为“" & aa & "”文件。"
        End If
    End If
End Sub

taller

1. Sub 导入数据()
   
2.     Dim p$, f$, Wb As Workbook, Arr
   
3.     Dim aa As String, Falg As Boolean
   
4.     aa = InputBox("请输入文件名：", "导入数据", 36)
   
5.     If StrPtr(aa) <> 0 Then
   
6.         p = ThisWorkbook.Path
   
7.         f = Dir(p & "" & aa & ".xls*")
   
8.         Do While f <> ""
   
9.             Set Wb = Workbooks.Open(p & "" & f)
   
10.             Arr = Wb.Sheets(1).Range("A2:h40").Value
    
11.             Wb.Close False
    
12.             f = Dir
    
13.             Falg = True
    
14.         Loop
    
15.         If Falg Then
    
16.             Application.ScreenUpdating = False
    
17.             Dim lastR As Long
    
18.             lastR = Sheet1.Cells(Rows.Count, 2).End(xlUp).Row
    
19.             Sheet1.Range("A" & lastR + 1).Resize(UBound(Arr), UBound(Arr, 2)) = Arr
    
20.             Sheet1.Range("A3", Sheet1.Cells(Sheet1.Rows.Count, 8).End(xlUp)).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, _
    
21.         8), Header:=xlNo
    
22.             Application.ScreenUpdating = True
    
23.         Else
    
24.             MsgBox "没有找到文件名为“" & aa & "”文件。"
    
25.         End If
    
26.     End If
    
27. End Sub

复制代码

ynzsvt

新增不重复的定义是什么

vbahappy

taller 发表于 2024-6-17 01:08

老师，有些问题呀，运行代码显示查不到36文件

vbahappy

ynzsvt 发表于 2024-6-17 05:07
新增不重复的定义是什么

就是原表中有的，就不需要导入进来，只导入原表中没有的

3190496160

vbahappy 发表于 2024-6-17 07:29
就是原表中有的，就不需要导入进来，只导入原表中没有的

根据什么判断原表中已经有了，总得有个判断的依据才行吧

vbahappy

3190496160 发表于 2024-6-17 07:34
根据什么判断原表中已经有了，总得有个判断的依据才行吧

不好意思，我现在才发现原表和数据源的的表头有些不一致，可能让老师疑惑了
就是品牌，规格，单位，数量，完全一致，就不需要导入
比如说：sample文件   这个已经有了，那么就不需要导入了
只导入

quqiyuan

参与一下，仅供参考。。。

3190496160

Sub 导入数据()
Application.ScreenUpdating = False
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Dim f$, Wb As Workbook
Dim aa As String
Dim ar As Variant, br As Variant
Dim arr()
aa = InputBox("请输入文件名：", "导入数据", 36)
If aa = "" Then MsgBox "您没有输入文件名！": End
p = ThisWorkbook.Path
f = Dir(p & "\" & aa & ".xls*")
If f = "" Then MsgBox "没有找到文件名为“" & aa & "”文件。": End
With ActiveSheet
    r = .Cells(Rows.Count, 2).End(xlUp).Row
    If r > 2 Then
        ar = .Range("a2:h" & r)
        For i = 2 To UBound(ar)
            If ar(i, 2) <> "" And ar(i, 3) <> "" Then
                zd = ar(i, 2) & "|" & ar(i, 3) & "|" & ar(i, 7) & "|" & ar(i, 8)
                d(zd) = i
            End If
        Next i
    End If
    Set Wb = Workbooks.Open(p & "\" & f)
    With Wb.Worksheets(1)
        rs = .Cells(Rows.Count, 2).End(xlUp).Row
        br = .Range("a2:h" & rs)
    End With
    Wb.Close False
    ReDim arr(1 To UBound(br), 1 To UBound(br, 2))
    For i = 2 To UBound(br)
        If br(i, 2) <> "" And br(i, 3) <> "" Then
            zd = br(i, 2) & "|" & br(i, 3) & "|" & br(i, 7) & "|" & br(i, 8)
            If Not d.exists(zd) Then
                n = n + 1
                For j = 1 To UBound(br, 2)
                    arr(n, j) = br(i, j)
                Next j
            End If
        End If
    Next i
    If n = "" Then MsgBox "没有需要更新的数据！": End
    .Cells(r + 1, 1).Resize(n, UBound(arr, 2)) = arr
End With
Application.ScreenUpdating = True
MsgBox "本次更新了" & n & "行数据！"
End Sub

3190496160