多工作薄数据汇总

Some歪2

多个工作薄数据汇总到，并提取该工作薄名称。数据可重复导入，如有修改覆盖原数据。跪谢大神帮助，谢谢

zmcsky

Sub test()
Dim f As String, mPath As String, Wb As Workbook, Sh As Worksheet
Dim k, i, v, j, str
If Workbooks.Count > 1 Then MsgBox "关闭其他工作簿！": Exit Sub
Dim dig As Object
      Set dig = Application.FileDialog(msoFileDialogFolderPicker)
       With dig
         .InitialFileName = ThisWorkbook.Path & "\"
         .Show
         If .SelectedItems.Count = 0 Then Exit Sub
         mPath = .SelectedItems(1) & "\"
         
         
       End With
     Set dig = Nothing

Sheet1.Cells.Clear
Sheet1.Cells(1, 1) = "文件名"
Sheet1.Cells(1, 2) = "表名 "
Sheet1.Cells(1, 5) = "SO "
Sheet1.Cells(1, 6) = "PO.NO"
Sheet1.Cells(1, 7) = "ITEM.NO"
Sheet1.Cells(1, 8) = "箱数/板数（外包装）"
Sheet1.Cells(1, 9) = "每箱/每板毛重KG """
Sheet1.Cells(1, 10) = "外包装（长cm）"
Sheet1.Cells(1, 11) = "外包装（宽cm）"
Sheet1.Cells(1, 12) = "外包装（高cm）"
Sheet1.Cells(1, 13) = "中文品名"
Sheet1.Cells(1, 14) = "英文品名"
Sheet1.Cells(1, 15) = "HS CODE"

'mPath = ThisWorkbook.Path  '指定路径，注意分层标记\
f = Dir(mPath & "*.xls")
Do While f <> ""
    If f <> ThisWorkbook.Name Then
    Set Wb = Workbooks.Open(mPath & f) '只读方式打开
    With Wb
          For Each Sh In .Worksheets
           
           If Sh.Name = "FCR" Then
           Else
           
             For j = 2 To Sh.Range("B65536").End(xlUp).Row
                        
            
                k = Sheet1.Range("a65536").End(xlUp).Row + 1
                  
                        Sheet1.Cells(k, 1) = Wb.Name
                        Sheet1.Cells(k, 2) = Sh.Name
'                        Sheet1.Cells(k, 3) = code
'                        Sheet1.Cells(k, 4) = size
                        
                        Sheet1.Cells(k, 5) = Sh.Cells(j, 1)
                        Sheet1.Cells(k, 6) = Sh.Cells(j, 2)
                        Sheet1.Cells(k, 7) = Sh.Cells(j, 3)
                        Sheet1.Cells(k, 8) = Sh.Cells(j, 4)
                        Sheet1.Cells(k, 9) = Sh.Cells(j, 5)
                        Sheet1.Cells(k, 10) = Sh.Cells(j, 6)
                        Sheet1.Cells(k, 11) = Sh.Cells(j, 7)
                        Sheet1.Cells(k, 12) = Sh.Cells(j, 8)
                        Sheet1.Cells(k, 13) = Sh.Cells(j, 9)
                        Sheet1.Cells(k, 14) = Sh.Cells(j, 10)
                        Sheet1.Cells(k, 15) = Sh.Cells(j, 11)
           
             Next j
            
            End If
            
          Next
         
    End With
    Wb.Close 0  '关闭文件
    End If
f = Dir '枚举,以访问下一个工作簿
Loop
MsgBox ("导入完成！")
End Sub

zmcsky

测试……………………

Some歪2

zmcsky 发表于 2017-8-10 15:37
Sub test()
Dim f As String, mPath As String, Wb As Workbook, Sh As Worksheet
Dim k, i, v, j, str

感谢大神，如果工作薄要添加了几个工作表，如何让VBA 固定汇总某个工作表的数据。而不是所有工作表的数据。

zmcsky

增加公式就可以了  sumif()