如何提取多工作簿中，不同列名的地址信息？

Andy19890610

同一文件夹中，有.xlsx、.xls多个工作簿。
每个工作簿的 表头是不一样的。


需要提取文件夹中，不同工作簿中的 收件地址信息，到新表格的第一列。

不同工作簿中的 地址信息的列名 为：收方|地址 、  收件详细地址、    收方地址。

如何用宏操作呢。

tanglf188

工作表名称不确定，列名还包含特殊字符|，有点麻烦

ykcbf1100

字段名太随心所欲了。处理数据的重点在于处理字段名了。

Andy19890610

ykcbf1100 发表于 2024-3-4 10:26
字段名太随心所欲了。处理数据的重点在于处理字段名了。

字段名是历史遗留问题了， 实际要提取的表格1000多个

Andy19890610

本楼作废，代码错误

ykcbf1100

附件供参考，因为字段名太混乱，不能保证所有数据都过来，不过收方地址能过来。

fzxba

提取地址信息.zip (57.46 KB, 下载次数: 8)

2024-3-4 10:35 上传

点击文件名下载附件

ykcbf1100

代码如下，以附件为准。

1. Sub ykcbf()  '//2024.3.4
   
2.     Set Fso = CreateObject("scripting.filesystemobject")
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     Set ws = ThisWorkbook
   
6.     Set sh = ws.Sheets("订单详情")
   
7.     With sh
   
8.         col = .Cells.Find("*", SearchOrder:=xlByColumns, searchdirection:=xlPrevious).Column
   
9.         For j = 1 To col
   
10.             s = .Cells(1, j)
    
11.             d(s) = j
    
12.         Next
    
13.     End With
    
14.     p = ThisWorkbook.Path & ""
    
15.     ReDim brr(1 To 10000, 1 To 100)
    
16.     For Each f In Fso.GetFolder(p).Files
    
17.         If f.Name Like "*.xls*" Then
    
18.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
19.                 fn = Fso.GetBaseName(f)
    
20.                 Set wb = Workbooks.Open(f, 0)
    
21.                 With wb.Sheets(1)
    
22.                     c = .Cells.Find("*", SearchOrder:=xlByColumns, searchdirection:=xlPrevious).Column
    
23.                     c1 = .Rows(1).Find("地址", , , , , 1).Column
    
24.                     r = .Cells(Rows.Count, c1).End(3).Row
    
25.                     arr = .[a1].Resize(r, c)
    
26.                     wb.Close False
    
27.                 End With
    
28.                 For i = 2 To UBound(arr)
    
29.                     m = m + 1
    
30.                     For j = 1 To UBound(arr, 2)
    
31.                         If j = c1 Then
    
32.                             s = "收方地址"
    
33.                         Else
    
34.                             s = arr(1, j)
    
35.                         End If
    
36.                         If d.exists(s) Then
    
37.                             brr(m, d(s)) = arr(i, j)
    
38.                         End If
    
39.                     Next
    
40.                 Next
    
41.             End If
    
42.         End If
    
43.     Next f
    
44.     With sh
    
45.         .UsedRange.Offset(1).Clear
    
46.         With .[a2].Resize(m, col)
    
47.             .Value = brr
    
48.             .Borders.LineStyle = 1
    
49.             .HorizontalAlignment = xlCenter
    
50.             .VerticalAlignment = xlCenter
    
51.         End With
    
52.     End With
    
53.     Application.ScreenUpdating = True
    
54.     Set d = Nothing
    
55.     MsgBox "OK！"
    
56. End Sub
    

复制代码

Andy19890610

ykcbf1100 发表于 2024-3-4 10:35
附件供参考，因为字段名太混乱，不能保证所有数据都过来，不过收方地址能过来。

感谢感谢！！！我自己能提4600条，你的代码能提取56000条 感谢！

Andy19890610

fzxba 发表于 2024-3-4 10:35

感谢感谢！！！运行速度很快，而且提取数量很正确 非常感谢！