如何将数组的部分元素输入到单元格区域

Qs18

nl054685 发表于 2024-9-9 18:07
非常感谢，高手也！

谢谢。。。。。。。。。。

nl054685

Qs18 发表于 2024-9-9 18:35
谢谢。。。。。。。。。。

老师我问你一下，如果我的文件夹里不只是有一个数据表，而是有多个数据表，怎么通过选择数据表来填充值呢？

Qs18

nl054685 发表于 2024-9-9 18:45
老师我问你一下，如果我的文件夹里不只是有一个数据表，而是有多个数据表，怎么通过选择数据表来填充值呢 ...

用循环来实现

nl054685

Qs18 发表于 2024-9-9 18:48
用循环来实现

我对vba纯小白一个，正在学习探索中，麻烦老师在你发的附件里修改好发出，供我学习借鉴使用

Qs18

1. Sub qs()
   
2.     Dim wb As Workbook, xb As Workbook, p As String, arr, brr, sht As Worksheet, dic, crr, drr
   
3.     Set dic = CreateObject("scripting.dictionary")
   
4.      Dim FileName
   
5.     Set wb = ThisWorkbook
   
6.     '可多选文件对话框
   
7.     FileName = Application.GetOpenFilename(FileFilter:="Excel 工作簿文件 (*.xls*),*.xls*", Title:="请选择文件", MultiSelect:=True)
   
8.     If Not IsArray(FileName) Then
   
9.         MsgBox "没有选择文件"
   
10.         Exit Sub
    
11.     End If
    
12.     For Each f In FileName '循环已经选了文件
    
13.         Set xb = Workbooks.Open(f, 0)
    
14.         For Each sht In xb.Worksheets
    
15.             dic.RemoveAll
    
16.             arr = xb.Sheets(sht.Name).Range("c2").Resize(1, 7).Value
    
17.             brr = xb.Sheets(sht.Name).Range("c23").Resize(1, 7).Value
    
18.             For i = 1 To UBound(brr, 2)
    
19.                 If Not dic.exists(brr(1, i)) Then
    
20.                     dic(arr(1, i)) = brr(1, i)
    
21.                 End If
    
22.             Next
    
23.             crr = wb.Sheets(sht.Name).Range("c2").Resize(1, 7).Value
    
24.             ReDim drr(1 To 1, 1 To UBound(crr, 2))
    
25.             For i = 1 To UBound(crr, 2)
    
26.                 drr(1, i) = dic(crr(1, i))
    
27.             Next
    
28.             r = wb.Sheets(sht.Name).Cells(Rows.Count, 1).End(xlUp).Row + 1
    
29.             wb.Sheets(sht.Name).Range("c" & r).Resize(1, 7) = drr
    
30.             wb.Sheets(sht.Name).Range("a" & r).Resize(1, 2).Merge
    
31.             wb.Sheets(sht.Name).Range("a" & r) = "姓名"
    
32.         Next
    
33.             xb.Close (0)
    
34.     Next f
    
35.     Set wb = Nothing: Set xb = Nothing
    
36.     Set sht = Nothing: Set dic = Nothing
    
37.     MsgBox "完成！"
    
38. End Sub
    

复制代码

Qs18

试试。。。。。

Qs18

再试试看。。。。。。。。