VBS编辑文件夹下所有excel文档

Function newExcel(fPath)
Dim x1sApp,xlsWorkBook,xlsSheet,xlsSheet1,xlsSheet2,x1sAppB,xlsWorkBookB,xlsSheetB
Set x1sApp = CreateObject("Excel.Application")  
Set xlsWorkBook = x1sApp.Workbooks.Open(fPath)   '指定excel文档路径  
Set xlsSheet1 = xlsWorkBook.Sheets(1)
Set xlsSheet2 = x1sApp.Workbooks(1)


Set x1sAppB = CreateObject("Excel.Application")  
Set xlsWorkBookB = x1sAppB.Workbooks.Open("D:\1.xlsx")   '指定excel文档路径  
set xlsSheetB = x1sAppB.Workbooks(1).Worksheets("Sheet1")   '指定要打开的sheet名称  

For i=1 to xlsWorkBook.Sheets.count step 1
    Dim tab_name : tab_name=xlsWorkBook.Sheets(i).name
	if instr(tab_name,"-")>0 Then
	b xlsWorkBookB,xlsSheetB,(Mid(tab_name,1,instr(tab_name,"-")-1)),(Mid(tab_name,instr(tab_name,"-")+1))
	'msgbox tab_name
	a xlsWorkBook,x1sApp.Workbooks(1).Worksheets(tab_name),xlsWorkBookB,xlsSheetB
	end if
Next
xlsWorkBookB.Close
x1sAppB.Quit
set x1sAppB = nothing
set xlsWorkBookB = nothing	
xlsWorkBook.Close
x1sApp.Quit
set x1sApp = nothing
set xlsWorkBook = nothing	
End Function 

Function FilesTree(sPath,sFunc)  
'遍历一个文件夹下的所有文件夹文件夹
    Dim i : i=0
    on error resume Next  
    Set oFso = CreateObject("Scripting.FileSystemObject")  
    Set oFolder = oFso.GetFolder(sPath)  
    Set oSubFolders = oFolder.SubFolders  
    Set oFiles = oFolder.Files  
    'For Each oFile In oFiles  
     '   WScript.Echo oFile.Path  
     '  'oFile.Delete  
    'Next  
    For Each oFile In oFiles
        If Right(oFile.Path,3)="xls" or Right(oFile.Path,4)="xlsx" Then
		Dim B : B=""&sFunc&"(oFile.Path)"
        Execute B
        i=i+1
        End If
    Next
    For Each oSubFolder In oSubFolders  
        WScript.Echo oSubFolder.Path  
        'oSubFolder.Delete  
        FilesTree(oSubFolder.Path)'递归  
    Next  
    Msgbox "您的"&sPath&"目录下，一共存在"&i&"个Excle文件"
    Wscript.Quit
    Set oFolder = Nothing  
    Set oSubFolders = Nothing  
    Set oFso = Nothing  
End Function  
  
FilesTree "D:\test","newExcel" '遍历 
msgbox "结束"
sub a(xlsWorkBook,xlsSheet,xlsWorkBookB,xlsSheetB)  '循环读取源表数据
    dim rwIndex     
    dim rowCount

     rowCount = xlsSheet.usedRange.Rows.Count
    on error Resume Next  
	'msgbox rowCount
    For rwIndex = 3 To rowCount   '指定要遍历的Excel行标  由于第1行是表头，从第2行开始  
            With xlsSheet
                If .Cells(rwIndex, 4).Value <> "" Then '如果遍历到第二列为空，则退出 
				   dim 	c1,c2,c3,c4
				   c1=.Cells(rwIndex, 4).Value 'name
				   c2=.Cells(rwIndex, 5).Value 'code
				   if .Cells(rwIndex, 7).Value="" then 'type&length
					c3=.Cells(rwIndex, 6).Value 
				   else
					c3=""&.Cells(rwIndex, 6).Value&"("&.Cells(rwIndex, 7).Value&")" 
				   end if
				   c4=.Cells(rwIndex, 4).Value 'desc
				   'msgbox c1
				   c xlsWorkBookB,xlsSheetB,c1,c2,c3,c4  
                End If  
            End With  

    Next 
    Exit Sub  
    End sub
sub b(xlsWorkBookB,xlsSheetB,tab_name,tab_code)  '表名列
    dim rwIndex     
    dim rowCount
     rowCount = xlsSheetB.usedRange.Rows.Count
	'msgbox rowCount
    on error Resume Next  
    For rwIndex = 1 To rowCount+1   '指定要遍历的Excel行标  由于第1行是表头，从第2行开始  
            With xlsSheetB
                If .Cells(rwIndex, 1).Value = "" Then '如果遍历到第一格为空，则新增并退出
				   .Cells(rwIndex, 1).Value = tab_name '新增表名
				   .Cells(rwIndex, 2).Value = tab_code '新增表代码
				   mgsbox .Cells(rwIndex, 1).Value
				   xlsWorkBookB.Save
                   Exit For  
                End If
            End With  

    Next
    Exit Sub  
    End sub 
sub c(xlsWorkBookB,xlsSheetB,c1,c2,c3,c4)  '新增字段
    dim rwIndex     
    dim rowCount
	
     rowCount = xlsSheetB.usedRange.Rows.Count
	'msgbox rowCount
    on error Resume Next  

    For rwIndex = 2 To rowCount+1   '指定要遍历的Excel行标  由于第1行是表头，从第2行开始  
            With xlsSheetB
                If .Cells(rwIndex, 1).Value = "" Then '如果遍历到第一格为空，则新增并退出
				   .Cells(rwIndex, 1).Value=c1 '新增列名
				   .Cells(rwIndex, 2).Value=c2 '新增列代码
				   .Cells(rwIndex, 3).Value=c3 '新增列类型
				   .Cells(rwIndex, 4).Value=c4 '新增列注释
				   '.Cells(rwIndex, 5).Value=c5 '是否主键
				   '.Cells(rwIndex, 7).Value=c6 '是否非空
				   xlsWorkBookB.Save
                   Exit For  
                End If
            End With  

    Next	
    Exit Sub  
    End sub 

　　

转载于:https://www.cnblogs.com/Babylon/p/9790749.html