将许多excel工作簿的数据复制到另一个excel工作簿

我是vb脚本的新手，不太了解所以请大家帮忙。将许多excel工作簿的数据复制到另一个excel工作簿

我有一个文件夹，它由许多子文件夹组成。每个子文件夹都有10个以上的Excel表格。我的目标是将来自所有子文件夹的每个excel文件中的数据复制到单个Excel表单中。问题是我写了一个代码，但它是覆盖，所以数据被删除。而且我们在所有的excel文件中都有相同的头文件，我希望头文件在主Excel文件中只出现一次。请提前帮助和thnakyou。

'Sub RunCodeOnAllXLSFiles() 
On Error Resume Next 


Set objExcel = CreateObject("Excel.Application") 


strPath = ":\Documents and Settings\faizat\Desktop\leeza" 
pathName="xlsx" 


If strPath = "" Then WScript.quit 
If pathName = "" Then WScript.quit 


'Creating an Excel Workbook in My Documents 
Set objWorkbook2= objExcel.Workbooks.Add() 


objExcel.Visible = True 
objExcel.DisplayAlerts = False 


Set objFso = CreateObject("Scripting.FileSystemObject") 
Set objFolder = objFso.GetFolder (strPath) 
Set objsubFolder = objfolder.subFolders 
Set objfile = objsubfolder.files 


For Each objsubfolder In objfolder.subfolders 

    For Each objFile In objsubFolder.Files 


     If objFso.GetExtensionName (objFile.Path) = "xlsx" Then 
      Set objWorkbook = objExcel.Workbooks.Open(objFile.Path) 


      Set objWorksheet = objWorkbook.WorkSheets(1) 
      objworksheet.Activate 


      ' Select the range on Sheet1 you want to copy 
      objWorkbook.Worksheets("SHEET1").usedrange.Copy 


      objworkbook.close 




      Set objRange = objExcel.Range("A2") 
      intNewRow = objExcel.ActiveCell.Row + 10 
      strNewCell = "A" & intNewRow 
      objExcel.Range(strNewCell).Activate 

      For i = 1 To usedrange 
       objWorksheet.Cells(intNewRow, 1) = i * 1 
       intNewRow = intNewRow + i 
      Next 

      ' Paste it on sheet1 of workbook2, starting at A1 
      objWorkbook2.Worksheets("Sheet1").Range(strNewCell).PasteSpecial 

      Set objWorksheet = objWorkbook2.Worksheets(1) 

     End If 
    Next 
Next

来源

2014-04-01 user3472113

太感谢你了，它的工作 – user3472113

For i = 1 To usedrange 
    objWorksheet.Cells(intNewRow, 1) = i * 1 
    intNewRow = intNewRow + i 
Next

你永远不会初始化变量usedrange，所以你的循环永远不会增加intNewRow。在脚本的开头初始化intNewRow与值1，并使用类似这样的内循环：

Set objWorkbook = objExcel.Workbooks.Open(objFile.Path) 

If intNewRow = 1 Then 
    startrow = 1 
Else 
    startrow = 2 
End If 
endrow = objWorkbook.Worksheets("SHEET1").UsedRange.Rows.Count 

objWorkbook.Worksheets("SHEET1").Range(startrow & ":" & endrow).Copy 
objWorkbook2.Worksheets("Sheet1").Cells(intNewRow, 1).PasteSpecial 

objWorkbook.close 

intNewRow = intNewRow + (endrow - startrow - 1)

来源

2014-04-01 18:34:00

非常感谢你的工作 – user3472113

将许多excel工作簿的数据复制到另一个excel工作簿

回答

相关问题