[原创]excel合并VBS代码
- hellohappy
- 网站管理员
- 帖子: 300
- 注册时间: 2018年11月18日, 14:27
- Been thanked: 5 time
#1 [原创]excel合并VBS代码
多个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
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
Link: | |
Hide post links |