[原创]excel合并VBS代码

[hellohappy]

多个excel第一张表合成一个excel多个表

Sub sheets2one()
    '定义对话框变量
    Dim cc As FileDialog
    Set cc = Application.FileDialog(msoFileDialogFilePicker)
    Dim newwork As Workbook
    Set newwork = Workbooks.Add
    With cc
        If .Show = -1 Then
            Dim vrtSelectedItem As Variant
            Dim i As Integer
            i = 1
            For Each vrtSelectedItem In .SelectedItems
                Dim tempwb As Workbook
                Set tempwb = Workbooks.Open(vrtSelectedItem)
                tempwb.Worksheets(1).Copy Before:=newwork.Worksheets(i)
                newwork.Worksheets(i).Name = VBA.Replace(tempwb.Name, ".xls", "")
                tempwb.Close SaveChanges:=False
                i = i + 1
            Next vrtSelectedItem
        End If
    End With
    Set cc = Nothing
End Sub


多个excel 横向合并


Option Explicit
On Error Resume Next
'保存为 merge.vbs 并在资源管理器中运行
'' 获取当先目录下所有的Excel文件名 ''
Dim objFSO
Dim sCurPath
Set objFSO = CreateObject("Scripting.FileSystemObject")
sCurPath = objFSO.GetAbsolutePathName(".")

Dim objFolder
Set objFolder = objFSO.GetFolder(sCurPath)

Dim colFiles,objFile
Dim arrFiles
arrFiles = Array()
Set colFiles = objFolder.Files
For Each objFile in colFiles
    ReDim Preserve arrFiles(UBound(arrFiles) + 1)
    arrFiles(UBound(arrFiles)) = objFile.Name
Next
arrFiles = Filter(arrFiles,".xls",True)

'' 打开一个新的Excel表格 ''

Dim objExcelAppResult
Set objExcelAppResult = WScript.CreateObject("Excel.Application")

Dim objWorkbookResult
Set objWorkbookResult = objExcelAppResult.WorkBooks.Add
objExcelAppResult.Visible = True
Dim objSheet
For Each objSheet in objWorkbookResult.Worksheets
    objSheet.Delete
Next

Dim objSheetResult
Set objSheetResult = objWorkbookResult.Worksheets(1)

'' 传送数据 ''
Dim objExcelAppEnum
Set objExcelAppEnum = WScript.CreateObject("Excel.Application")
Dim objWorkbookEnum
Dim i,ii,iifirst,j,jj
Dim bFirstColSaved
Dim sCellValue,sName
Dim iRow,iCol,iColResult
Dim RowsCount,ColCount
bFirstColSaved = False
iColResult = 3
For i = 0 to UBound(arrFiles)
    Set objWorkbookEnum = objExcelAppEnum.WorkBooks.Open( sCurPath & "\" & arrFiles(i) )
    For Each objSheet in objWorkbookEnum.Worksheets
        objSheet.Activate
        RowsCount=objSheet.UsedRange.Rows.Count
        ColCount=objSheet.UsedRange.Columns.Count
        '找到该表的第一对称行,用于对称复制行
        for ii = 5 to 20
            if objSheet.Cells(ii,2).Value then
                if bFirstColSaved = False then
                    iifirst = ii
                    ii = 4
                else
                    ii = iifirst - ii +4
                end if
                exit for 
            else
                
            end if
        next
        if iifirst = "" then
            MsgBox("出错！")
        end if
        
        '' 传送第一列 ''
        If bFirstColSaved = False then
            iRow = 1
            Do
                sCellValue = objSheet.Cells(iRow,2).Value
                If sCellValue Then
                    objSheetResult.Cells(iRow+4,2).Value = sCellValue
                Else
                    If iRow > RowsCount then
                        Exit Do
                    end if
                End If
                iRow = iRow + 1
            Loop
            bFirstColSaved = True
        End If
        
        iCol = 3
        '' 传送行数据 ''
        for iCol = 3 to ColCount
            for  iRow = 1 to RowsCount
                sCellValue = objSheet.Cells(iRow,iCol).Value
                If sCellValue Then
                    objSheetResult.Cells(iRow+ii,iColResult).Value = sCellValue
                end if 
            next
            iColResult = iColResult + 1 
        next

    Next
    objWorkbookEnum.Saved = True
    objWorkbookEnum.Close()
Next
MsgBox("顺利结束！")
MsgBox i
objExcelAppEnum.Quit

纵向复制文件到一个excel文件中

'******************************************
'拖拽文件，获取文件路径
'******************************************
If WScript.Arguments.Count = 0 Then
        MsgBox "拖拽文件到本图标", 0, "提示"
End If

dim strPath(100)

For a = 0 To WScript.Arguments.Count - 1
 
    strPath(a+1) = WScript.Arguments(a)
    
Next
'' 打开一个新的Excel表格 ''

Dim objExcelAppResult
Set objExcelAppResult = WScript.CreateObject("Excel.Application")

Dim objWorkbookResult
Set objWorkbookResult = objExcelAppResult.WorkBooks.Add
objExcelAppResult.Visible = false

Dim objSheetResult
Set objSheetResult = objWorkbookResult.Worksheets(1)

'******************************************
'定义Excle对象、工作薄对象、工作表对象
'******************************************
Dim oExcel, oWb, oSheet , j,num,wbn,ncol,nrow,i
num = 0
i = 1
Set ws = WScript.CreateObject("wscript.shell")
Set oExcel = CreateObject("Excel.Application")
for a = 1 to WScript.Arguments.Count
    '打开指定的工作簿
    Set oWb = oExcel.Workbooks.Open(strPath(a))
    '显示打开的Excel工作簿
    oExcel.Visible = True
    '******************************************
    '遍历工作簿的所有工作表
    '******************************************
    For j = 1 To oWb.Sheets.Count
        Set oSheet = oWb.Sheets(j)
        oSheet.Activate
        with owb.ActiveSheet
            ncol = .UsedRange.columns.count
            nrow = .UsedRange.rows.count
            i = nrow + i + 1
            num = num + 1
            WbN = WbN&Chr(13) & .Name
            .UsedRange.Copy
            objSheetResult.Range("A"&(i-nrow)).select
            objWorkbookResult.ActiveSheet.Paste
            '.UsedRange.Copy objSheetResult.Range("A"&(i-nrow)&":"&ChgNumToABC(ncol)&(i-1))
            '.UsedRange.Copy objSheetResult.Range("A"&(i-nrow))
        end with
    next
next
'MsgBox "共合并了" &Num& "个工作薄下的全部工作表。如下：" &Chr(13)& wbn, "提示"


'*****************************************************************************
'将Excel中列数转换为列名（如27列--->AA列）
'参数：var 列数
'返回：列名 string
'*****************************************************************************
Function ChgNumToABC(var)            '(ByVal var As Integer) As String
    Dim res 'As String  
    Dim remainder 'As Integer '余数
    Dim quotient 'As Integer    '商
 
    remainder = var Mod 26
    
    If remainder = 0 Then
        var = var - 26
        remainder = 26
    End If
    
    quotient = var \ 26
    
    If quotient <> 0 Then
        res = ChgNumToABC(quotient)
    End If
    
    ChgNumToABC = res & Chr(remainder + 65 - 1)
End Function