合并多个excel文件内容

转载 2016年05月31日 10:41:58
  1. 我们需要把多个excel表都放在同一个文件夹里面,并在这个文件夹里面新建一个excel。



  2. 用microsoft excel打开新建的excel表,并右键单击sheet1,找到“查看代码”,单击进去。进去之后就看到了宏计算界面。


  3. 然后我们把下面这些宏计算的代码复制进去,然后找到工具栏上面的“运行”下的“运行子过程/用户窗体”,代码如下。

    Sub 合并当前目录下所有工作簿的全部工作表()

    Dim MyPath, MyName, AWbName

    Dim Wb As Workbook, WbN As String

    Dim G As Long

    Dim Num As Long

    Dim BOX As String

    Application.ScreenUpdating = False

    MyPath = ActiveWorkbook.Path

    MyName = Dir(MyPath & "\" & "*.xls")

    AWbName = ActiveWorkbook.Name

    Num = 0

    Do While MyName <> ""

    If MyName <> AWbName Then

    Set Wb = Workbooks.Open(MyPath & "\" & MyName)

    Num = Num + 1

    With Workbooks(1).ActiveSheet

    .Cells(.Range("B65536").End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4)

    For G = 1 To Sheets.Count

    Wb.Sheets(G).UsedRange.Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 1)

    Next

    WbN = WbN & Chr(13) & Wb.Name

    Wb.Close False

    End With

    End If

    MyName = Dir

    Loop

    Range("B1").Select

    Application.ScreenUpdating = True

    MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下:" & Chr(13) & WbN, vbInformation, "提示"

    End Sub



  4. 运行之后,等待10秒针左右,等运行完毕,就是合并完成之后,会有提示,点确定就可以了。查看合并后的数据,有5000多行,就是同一个文件夹里面17个excel表数据合并后的结果。效果如图所示。


-------------------------------------------------------------自己完成作品的宏---------------------------------------------------------------------------------------

'This macro is combining all data from different excel in a same folder  
'Stones create on 2017/3/3  
Sub CombineData()  
    'define variable  
    Dim FilePath, SingleFileName, ActiveWbName  
  
    Dim TraverseBook As Workbook, ALLWbName As String  
      
    Dim FileNum As Long  
      
    'stop screen-updating for user so program runs more fast  
    Application.ScreenUpdating = False  
      
    'get file path  
    FilePath = ActiveWorkbook.Path  
  
    SingleFileName = Dir(FilePath & "\" & "*.xlsx")   
  
    ActiveWbName = ActiveWorkbook.Name  
  
    FileNum = 0  
      
    'traverse all different work book  
    Do While SingleFileName <> ""  
  
        If SingleFileName <> ActiveWbName Then  
  
        Set TraverseBook = Workbooks.Open(FilePath & "\" & SingleFileName)  
          
        'count file number  
        FileNum = FileNum + 1  
        'get all workbook name  
        ALLWbName = ALLWbName & Chr(13) & TraverseBook.Name  
          
        'Close workbook without saving  
        TraverseBook.Close False  
  
        End If  
      
    'reset next file name into SingleFileName variable  
    SingleFileName = Dir  
  
    Loop  
      
    'show the result  
    Application.ScreenUpdating = True  
    MsgBox "combined" & FileNum & "excel as following:" & Chr(13) & ALLWbName, vbInformation, "notification"  
    '***auto save combine excel  
    'save change in active workbook  
    'ActiveWorkbook.Save  
End Sub  




'This macro is combining all data from different excel in a same folder
'Stones create
Sub CombineData()
    'define variable
    Dim FilePath, SingleFileName, ActiveWbName

    Dim Wb As Workbook, ALLWbName As String
    
    Dim FileNum As Long
    
    'stop scrrenupdating for user so program runs more fast
    Application.ScreenUpdating = False
    
    'get file path
    FilePath = ActiveWorkbook.Path

    SingleFileName = Dir(FilePath & "\" & "*.xlsx")

    ActiveWbName = ActiveWorkbook.Name

    FileNum = 0
    
    'last row index of combine excel active sheet
    Dim ComLastRowIndex As Long
    ComLastRowIndex = 6
    'shee2 last row index of conbine excel active sheet
    Dim sheet2RowIndex As Long
    sheet2RowIndex = 2
    
    'BC in very single excel
    Dim sinBC As String
    'BU in every single excel
    Dim sinBU As String
    'Country in very single excel
    Dim sinCountry As String
    
        
    'traverse all different work book
    Do While SingleFileName <> ""

        If SingleFileName <> ActiveWbName Then

        Set Wb = Workbooks.Open(FilePath & "\" & SingleFileName)
        
        'count file number
        FileNum = FileNum + 1
        'get all workbook name
        ALLWbName = ALLWbName & Chr(13) & Wb.Name
        
        'get BC BU Country in every single excel then put into Q R S column
        sinBC = Mid(Wb.Name, 37, 3)
        sinBU = Mid(Wb.Name, 30, 3)
        sinCountry = Mid(Wb.Name, 5, 5)
        
        'open Top 20 Past Due Customers sheet
        Sheets("Top 20 Past Due Customers").Select
        'unhide all rows
        Rows("1:" & ActiveSheet.Rows.Count).Select
        Selection.EntireRow.Hidden = False
             
        'aging table which last row index of B column including customer name
        Dim SinAgingLastRowIndex As Long
        SinAgingLastRowIndex = 6
        
    '******Aging table******
        'get last row index in  aging table every single Excel
        Do While Range("B" & SinAgingLastRowIndex) <> ""
            SinAgingLastRowIndex = SinAgingLastRowIndex + 1
        Loop
    
        'if single excel has actual data then copy the data
        If SinAgingLastRowIndex > 6 Then
    
            'select aging data area A6 - P *
            'Range("A6:P*").Select
            Range("A6:P" & (SinAgingLastRowIndex - 1)).Select
            Selection.Copy
            'jump to conbine excel
            Workbooks("combine.xlsm").Activate
            Sheets("1").Select
            'find A column to paste
            Range("A" & ComLastRowIndex).PasteSpecial xlPasteValues
            
            Application.CutCopyMode = False
            
            'set BU BC values in Q(BC) & R(BU) column
            Range("Q" & ComLastRowIndex & ":Q" & (ComLastRowIndex + SinAgingLastRowIndex - 1 - 6)).Value = sinBC
            Range("R" & ComLastRowIndex & ":R" & (ComLastRowIndex + SinAgingLastRowIndex - 1 - 6)).Value = sinBU
            Range("S" & ComLastRowIndex & ":S" & (ComLastRowIndex + SinAgingLastRowIndex - 1 - 6)).Value = sinCountry
            
            'reset combine excel lastRowIndex by adding new row number
            ComLastRowIndex = ComLastRowIndex + SinAgingLastRowIndex - 6
        
        End If
        
    '******No Balance table******
        'jump to single excel window to copy no balance data
        Wb.Activate
        'No Balance table which start and last row index of B column
        Dim SinNBalStartIndex As Long
        Dim SinNBalLastRowIndex As Long
        
        SinNBalLastRowIndex = 0
        'find fixed cell , get row number of cell
        SinNBalStartIndex = Cells.Find(What:="Accounts below the threshold. No commentary needed", MatchCase:=False).Row + 1
        
        'find no balance table last row index of every single Excel
        SinNBalLastRowIndex = Cells.Find(What:="Grand Totals", MatchCase:=False).Row - 1
        
        'if no balance table has data then copy the data
        
        If SinNBalStartIndex <= (SinNBalLastRowIndex) Then
            Range("A" & SinNBalStartIndex & ":P" & (SinNBalLastRowIndex)).Select
            Selection.Copy
            'jump to conbine excel
            Workbooks("combine.xlsm").Activate
            Sheets("2").Select
            Range("A" & sheet2RowIndex).PasteSpecial xlPasteValues
      
            Application.CutCopyMode = False
            
            'set BC BU Country valuses in Q & R & S column
            'Range ("Q" & sheet2RowIndex & ":Q" & (sheet2RowIndex + SinNBalLastRowIndex - SinNBalStartIndex + 1 - 1))
            Range("Q" & sheet2RowIndex & ":Q" & (sheet2RowIndex + SinNBalLastRowIndex - SinNBalStartIndex)) = sinBC
            Range("R" & sheet2RowIndex & ":R" & (sheet2RowIndex + SinNBalLastRowIndex - SinNBalStartIndex)) = sinBU
            Range("S" & sheet2RowIndex & ":S" & (sheet2RowIndex + SinNBalLastRowIndex - SinNBalStartIndex)) = sinCountry
            
            'get sheet2 start place to paste no balace data for next time
            sheet2RowIndex = sheet2RowIndex + SinNBalLastRowIndex - SinNBalStartIndex + 1
        
        End If
        
        'Close workbook without saving
        Wb.Close False

        End If
    
    'reset next file name into SingleFileName variable
    SingleFileName = Dir

    Loop
    
    '******Cope sheet2 to sheet1******
    Range("A1:S" & sheet2RowIndex).Copy
    Sheets("1").Select
    Range("A" & (ComLastRowIndex + 2)).PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    
    'show the result
    Application.ScreenUpdating = True
    MsgBox "combined" & FileNum & "excel as following:" & Chr(13) & ALLWbName, vbInformation, "notification"
    '***auto save combine excel
    'save change in active workbook
    'ActiveWorkbook.Save
End Sub



相关文章推荐

使用excel批量合并子文件内容到一个文件内

说到excel大家应该都不陌生,也都对它强大的功能有所耳闻,自己虽然已经用了好多年,但也只能算入门水平,比如今天遇到的一个实际情况就完全不知道怎么处理,上网查阅资料之后才解决,这里记录一下。 实...

poi 解析excel文件内容demo

  • 2015-10-20 18:24
  • 17.40MB
  • 下载

在多个Word文档中查找指定文件内容

文件分捡工具,可以根据你的需要设置不同的关键词,如上图,只要搜索指定的关键词(以逗号分隔),就可以实现对一个目录中的所有简历文件进行归类统计,统计每个简历中文件出现的次数,并可以按关键词类别或者匹配的...
  • urhero
  • urhero
  • 2016-08-09 13:20
  • 2000

java获取上传Excel文件内容

  • 2017-09-22 15:20
  • 708KB
  • 下载

使用POI读取excel文件内容

1.前言 项目中要求读取excel文件内容,并将其转化为xml格式。常见读取excel文档一般使用POI和JExcelAPI这两个工具。这里我们介绍使用POI实现读取excel文档。 2....

PHP读取Excel文件内容

项目需要读取Excel的内容,从百度搜索了下,主要有两个选择,第一个是PHPExcelReader,另外一个是PHPExcel。   PHPExcelReader比较轻量级,仅支持Exce...
内容举报
返回顶部
收藏助手
不良信息举报
您举报文章:深度学习:神经网络中的前向传播和反向传播算法推导
举报原因:
原因补充:

(最多只允许输入30个字)