將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`