将excel从一个文件夹合并到多个工作表中

Question

我正在寻找一个代码/宏，将一个文件夹位置（可能未打开）中的不同excel文件合并到具有与个人同名的多个工作表的excel中excel名称 谢谢

Answer 1

我能够通过搜索这个相同的问题找到这些宏。大约有4种不同的。没有两个来自同一个来源。编码时，如果你不能自己想出答案，它就会成为Google的益智游戏。

Sub GetSheets() 
Dim temp As String 
Dim name As String 
Dim filename As String 
Dim sheetName As String 
Dim counter As Integer 
Dim upper As Long 
Dim myArray() As String 

temp = Range("A2").Value 
Path = StripFilename(temp) 

On Error Resume Next 
upper = UBound(myArray) 
On Error GoTo 0 

counter = 0 
filename = Dir(Path & "*.xls") 
Application.DisplayAlerts = False 

Do While filename <> "" 
    On Error Resume Next 
    upper = UBound(myArray) 
    On Error GoTo 0 
    ReDim Preserve myArray(upper + 1) 

    Workbooks.Open filename:=Path & filename, ReadOnly:=True 
    sheetName = FileNameNoExt(filename) 
    myArray(counter) = sheetName 

    For Each sheet In ActiveWorkbook.Sheets 
     If sheet.name = "Report" Then 
      If Len(myArray(counter)) <= 31 Then 
      sheet.name = myArray(counter) 
      Else 
      sheet.name = Left(myArray(counter), 31) 
      End If 
      sheet.copy After:=ThisWorkbook.Sheets(1) 
     End If 

    Next sheet 

    Workbooks(filename).Close False 

    filename = Dir() 
    counter = counter + 1 
Loop 

Sheets(1).Select 
Application.DisplayAlerts = True 
End Sub 

此函数从单元格A2获取指定文件路径中的文件。然后它会检查工作表的名称，并将其与“报告”进行比较，如果工作表名称为“报告”，则将其复制（这适用于我需要的情况，可以删除'if'语句并复制）。这是你运行的主要部分。以下函数仅仅是帮助函数用于帮助获取没有扩展名/路径/等的文件名。

`Function StripFilename(sPathFile As String) As String 

'given a full path and file, strip the filename off the end and return the path 
    Dim filesystem As New FileSystemObject 
    StripFilename = filesystem.GetParentFolderName(sPathFile) & "\" 

End Function 

Function GetFilenameFromPath(ByVal strPath As String) As String 
' Returns the rightmost characters of a string upto but not including the rightmost '\' 

    If Right$(strPath, 1) <> "\" And Len(strPath) > 0 Then 
     GetFilenameFromPath = GetFilenameFromPath(Left$(strPath, Len(strPath) - 1)) + Right$(strPath, 1) 
    End If 
End Function 

Function FileNameNoExt(strPath As String) As String 
    Dim strTemp As String 
    strTemp = Mid$(strPath, InStrRev(strPath, "\") + 1) 
    FileNameNoExt = Left$(strTemp, InStrRev(strTemp, ".") - 1) 
End Function`