请教大神如何将多个excel合并汇总且提取相应的文件名到首列

wanl01

请教大神如何将多个excel合并汇总且提取相应的文件名到首列

里面的格式内容都是一样的，我知道用vb可以把全部excel合并汇总。


但我有个需求要在汇总表每条信息的首列加上相应的文件名，以此区分开来，

相应表格和汇总表格式已在附件。


请教大神，谁可以帮我写一下代码，谢谢了，。~~~~~~

lsc900707

晚上有时间解压附件后再说。

fxl447098457

有一个文件标题货号多了一列，与其他的两个文件不一致。自己注意。

1. Sub hebing()
   
2. Dim fn As String, arr As Variant, ss As String, brr As Variant, Rng As Range
   
3. Application.ScreenUpdating = False
   
4. If Not IsEmpty(UsedRange) Then UsedRange.ClearContents
   
5. fn = Dir(ThisWorkbook.Path & "\*.xlsx")
   
6. arr = Array("文件名", "品牌名称", "商品排位", "货号", "货号", "款式细类", _
   
7. "正品价", "售价 ", "材质", "售卖周期", "总备货量", "备货值（货值）", _
   
8. "总销售额（未扣满减未扣拒退）", "总销售量（未扣拒退）", "库存量", _
   
9. "销售额(扣满减未扣拒退)", "满减金额", "uv", "客单价", "转化率", "购买人数", _
   
10. "售卖比", "售罄状态", "sku售罄率", "三级分类销售量", "三级分类销售额", _
    
11. "三级分类售卖比", "第一天销售量", "第一天售卖比", "推荐等级", "拒收量", _
    
12. "拒收率", "拒收金额", "退货量", "退货率", "退货金额", "拒退量", "拒退率", _
    
13. "拒退额", "移动端销售量", "移动端销售额", "移动端销售量占比", _
    
14. "移动端销售额占比", "移动端UV", "移动端购买人数", "移动端转化率", "移动端UV占比")
    
15. [a1].Resize(, UBound(arr) + 1) = arr
    
16. Do While Len(fn)
    
17. With Workbooks.Open(Filename:=ThisWorkbook.Path & "" & fn)
    
18.     ss = Split(.Name, ".xls")(0)
    
19.     brr = Intersect(.Sheets(1).UsedRange, .Sheets(1).UsedRange.Offset(1))
    
20.     Set Rng = Cells(Rows.Count, 1).End(3)(2)
    
21.     Rng(, 2).Resize(UBound(brr), UBound(brr, 2)) = brr
    
22.     Rng.Resize(UBound(brr)) = ss
    
23.     .Close 0
    
24. End With
    
25. fn = Dir
    
26. Loop
    
27. Application.ScreenUpdating = True
    
28. Set Rng = Nothing
    
29. End Sub

复制代码

fxl447098457

。。附件。。。。 新建文件夹 - 副本.rar (157.06 KB, 下载次数: 47)

2017-3-10 11:38 上传

点击文件名下载附件

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim wb As Workbook
   
5.   Dim ws As Worksheet
   
6.   Dim ws0 As Worksheet
   
7.   Dim mypath$, myname$
   
8.   Application.ScreenUpdating = False
   
9.   Application.DisplayAlerts = False
   
10.   Set ws0 = Worksheets("sheet1")
    
11.   With ws0
    
12.     .UsedRange.Offset(1, 0).Clear
    
13.   End With
    
14.   mypath = ThisWorkbook.Path & ""
    
15.   myname = Dir(mypath & "*.xlsx")
    
16.   Do While myname <> ""
    
17.     Set wb = GetObject(mypath & myname)
    
18.     With wb
    
19.       With .Worksheets(1)
    
20.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
21.         c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    
22.         With ws0
    
23.           r0 = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
    
24.         End With
    
25.         .Range("a2").Resize(r - 1, c).Copy ws0.Cells(r0, 2)
    
26.         With ws0
    
27.           .Cells(r0, 1).Resize(r, 1) = Split(myname, ".")(0)
    
28.         End With
    
29.       End With
    
30.       .Close False
    
31.     End With
    
32.     myname = Dir()
    
33.   Loop
    
34. End Sub
    

复制代码

chxw68

详见附件。

wanl01

chxw68 发表于 2017-3-10 12:52

不行啊，附件也跟我的没变化呀 ？

wanl01

fxl447098457 发表于 2017-3-10 11:36
有一个文件标题货号多了一列，与其他的两个文件不一致。自己注意。

大神，为什么我运用的时候不行的呢？显示着这个。。