跨簿的复制内容

LVMJ2023

各位老师好，请指教

7176386

可以把工作薄数据存放到通用数组，然后直接调用后输出。

LVMJ2023

7176386 发表于 2023-2-7 14:04
可以把工作薄数据存放到通用数组，然后直接调用后输出。

好的，我按这个思路查下怎么操作

LVMJ2023

7176386 发表于 2023-2-7 14:04
可以把工作薄数据存放到通用数组，然后直接调用后输出。

一个簿的宏无法作用到其它簿是吗？

7176386

LVMJ2023 发表于 2023-2-7 14:07
一个簿的宏无法作用到其它簿是吗？

1. '检查文档是否打开
   
2. Function JcDk(Optional Mc As Variant) As String
   
3.     Dim Wd(1 To 3) As Variant, Wrk As Workbook
   
4.     If Len(Mc) = 0 Then
   
5.         Debug.Print "检查文档是否打开 不处理为空的路径！"
   
6.     Else
   
7.         Wd(1) = Mid(Mc, InStrRev(Mc, "") + 1, Len(Mc) - InStrRev(Mc, "")) '工作薄名称
   
8.         Wd(2) = Mid(Mc, 1, InStrRev(Mc, "") - 1)                           '工作薄路径
   
9.         For Each Wrk In Workbooks
   
10.             With Wrk
    
11.                 If .Name = Wd(1) Then
    
12.                     If .Path = Wd(2) Then
    
13.                         JcDk = Wd(1)
    
14.                     Else
    
15.                         MsgBox "请关闭相同名称的工作薄“" & Wd(1) & "”", 16
    
16.                         JcDk = "Err"
    
17.                     End If
    
18.                     Exit For
    
19.                 End If
    
20.             End With
    
21.         Next Wrk
    
22.     End If
    
23.     Set Wrk = Nothing
    
24. End Function
    
25. '文档打开自定义函数
    
26. Function DkWd(Optional Mc As Variant) As String
    
27. '    On Error Resume Next
    
28.     Dim Wrk As Workbook
    
29.     Dim Wd(1 To 2) As Variant
    
30.     Wd(1) = Mid(Mc, InStrRev(Mc, "") + 1, Len(Mc) - InStrRev(Mc, "")) '工作薄名称
    
31.     Wd(2) = Mid(Mc, 1, InStrRev(Mc, "") - 1)                           '工作薄路径
    
32.     Set Wrk = GetObject(Mc)
    
33.     If Wrk Is Nothing Then
    
34.         DkWd = "Err"
    
35.         MsgBox "无法打开工作薄“" & Wd(1) & "”", 16
    
36.     Else
    
37.         DkWd = Wd(1)
    
38.     End If
    
39.     Set Wrk = Nothing
    
40. End Function

复制代码

7176386

'文档打开自定义函数

可以在这个函数这里，读取到文件后，把数据用数组存起来

LVMJ2023

7176386 发表于 2023-2-7 14:13
'文档打开自定义函数

可以在这个函数这里，读取到文件后，把数据用数组存起来

好的谢谢，我试着操作下，有些东西没摸过

3190496160

Sub 匹配分组()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("样本")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "样本为空！": End
    ar = .Range("a6:n" & r)
End With
For j = 2 To UBound(ar, 2)
    If Trim(ar(1, j)) <> "" Then
        d(Trim(ar(1, j))) = j
    End If
Next j
lj = ThisWorkbook.Path & "\"
f = Dir(lj & "*.xls*")
Do While f <> ""
    If f <> ThisWorkbook.Name Then
        Set wb = Workbooks.Open(lj & f, 0)
        With wb.Worksheets("1")
            rs = .Cells(Rows.Count, 2).End(xlUp).Row
            If rs > 1 Then .Range("b2:c" & rs) = Empty
            br = .Range("b1:c" & r)
            For j = 1 To 2
                n = 1
                lh = d(Trim(br(1, j)))
                If lh <> "" Then
                    For i = 2 To UBound(ar)
                        n = n + 1
                        br(n, j) = ar(i, lh)
                    Next i
                End If
            Next j
            If n > 1 Then
                .[b1].Resize(n, 2) = br
            End If
        End With
        wb.Close False
    End If
f = Dir
Loop
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

3190496160

新建文件夹.rar (81.4 KB, 下载次数: 10)

2023-2-7 15:10 上传

点击文件名下载附件