功能介绍：
1.纵向复制文件到一个excel文件中；
将要进行纵向合并的excel文件一起拖到 这个代码的vbs文件 的图标上面，会自动生成一个excel然后横向合并文件
只能合并每个excel文档的第一个sheet表，如果想要合并所有表可以自己改写，Set objSheetResult = objWorkbookResult.Worksheets(1)这一行代码是关键哦。
2.横向合并excel
将想要横向合并的excel文档放到 这个代码的vbs文件 所在的文件夹，双击该vbs图标。
横向合并所在文件夹下面的所有excel文档的第一个sheet表，想合并所有sheet表同上。
3.删除重复的标题和表头
若使用了纵向合并，合并了excel表，但是事实上你的每一个excel表的表头或者标题等都是重复的，
那么你的新excel文档大概长这样：
标题和表头
数据
标题和表头
数据
标题和表头
数据
。。。
我们只需要第一个标题和表头，其他的都可以删掉了，这个代码就是这么用的。
拖动要删标题和表头的excel到 这个代码的vbs文件 的图标上面，会自动完成上面功能。
其中需要修改的是代码：
If 15 < RowsCount Then
中的数字15，只要这个数字大于第一个标题和表头的最后一行的行数小于第二个标题和表头的第一行的行数
For ii = RowsCount to 15 step -1
中的数字15，只要这个数字大于第一个标题和表头的最后一行的行数小于第二个标题和表头的第一行的行数
k =oSheet.range("B"&ii).Value = "" or oSheet.range("B"&ii).Value = "city" or oSheet.range("B"&ii).Value = "City"
中的检索条件（也就是等号右侧的部分），原来的代码的意思是：
当sheet表的第二例（B列）的第 ii 行的值为City或者city时候，这一行为表头行，所以k赋值等于1。
当sheet表的第二例（B列）的第 ii 行的值为空的时候，这一行为标题，k也赋值为1
同样道理你可以让他检测某一列的看看某个单元格是什么判断是否为标题或者表头
当然你也可以改写成多列的检测条件需要自己琢磨。
1.纵向复制文件到一个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
2.横向合并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
3.删除重复的标题和表头：
'******************************************
'拖拽文件，获取文件路径
'******************************************
If WScript.Arguments.Count = 0 Then
MsgBox "拖拽文件到本图标", 0, "提示"
End If
For a = 0 To WScript.Arguments.Count - 1
strPath = WScript.Arguments(a)
Next
'******************************************
'定义Excle对象、工作薄对象、工作表对象
'******************************************
Dim oExcel, oWb, oSheet , j ,ii ,k
Set ws = WScript.CreateObject("wscript.shell")
Set oExcel = CreateObject("Excel.Application")
'打开指定的工作簿
Set oWb = oExcel.Workbooks.Open(strPath)
'显示打开的Excel工作簿
oExcel.Visible = True
'******************************************
'遍历工作簿的所有工作表
'******************************************
For j = 1 To oWb.Sheets.Count
Set oSheet = oWb.Sheets(j)
'选中并激活工作表
oSheet.Activate
'oSheet.Range("A1") = "成功"
'数一下有多少行数据
RowsCount=oSheet.UsedRange.Rows.Count
If 15 < RowsCount Then
For ii = RowsCount to 15 step -1
k =oSheet.range("B"&ii).Value = "" or oSheet.range("B"&ii).Value = "city" or oSheet.range("B"&ii).Value = "City"
If k then
oExcel.ActiveSheet.Rows(ii).Delete
end if
next
End If
next
发表于 2018-9-27 00:00
|
发表于 2018-9-27 21:28
