vba-记录从同文件夹下根据sheet名批量导入数据的方法

Sub CopyFilesToSheetsFromFolder()
	Dim selectedFile As Variant
	Dim targetWorkbook As Workbook
	Dim sourceWorkbook As Workbook
	Dim ws As Worksheet
	Dim fso As Object
	Dim folder As Object
	Dim file As Object
	Dim successMessage As String
	Dim failureMessage As String
	Dim sheetCopied As Boolean

	' 让用户选择要处理的文件
	selectedFile = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls; *.xlsx), *.xls; *.xlsx", _
												Title:="Select File", MultiSelect:=False)
	' 检查用户是否选择了文件
	If TypeName(selectedFile) = "Boolean" Then
		MsgBox "No file selected."
		Exit Sub
	End If

	' 打开目标工作簿
	Set targetWorkbook = Workbooks.Open(selectedFile)
	successMessage = "粘贴成功:" & vbCrLf
	failureMessage = "未查找到文件:" & vbCrLf

	' 获取目标文件所在文件夹路径
	Dim folderPath As String
	folderPath = Left(selectedFile, InStrRev(selectedFile, "\") - 1)

	' 创建FileSystemObject
	Set fso = CreateObject("Scripting.FileSystemObject")
	Set folder = fso.GetFolder(folderPath)

	' 遍历目标工作簿中的所有工作表
	For Each ws In targetWorkbook.Sheets
		sheetCopied = False
		' 遍历文件夹中的文件
		For Each file In folder.Files
			' 获取文件名（不包括扩展名）
			Dim fileNameWithoutExtension As String
			fileNameWithoutExtension = Left(file.Name, InStrRev(file.Name, ".") - 1)
			
			' 如果文件名包含工作表名称且不是目标工作簿本身
			If InStr(1, fileNameWithoutExtension, ws.Name, vbTextCompare) > 0 And file.Path <> selectedFile Then
				' 打开源工作簿
				Set sourceWorkbook = Workbooks.Open(file.Path)
				' 清空目标Sheet内容
				ws.Cells.Clear
				' 复制源工作簿的第一个Sheet内容到目标Sheet
				sourceWorkbook.Sheets(1).Cells.Copy Destination:=ws.Cells
				' 添加反馈信息
				successMessage = successMessage & file.Name & " -> " & ws.Name & vbCrLf
				' 关闭源工作簿
				sourceWorkbook.Close SaveChanges:=False
				' 标记为已复制
				sheetCopied = True
				' 退出文件循环
				Exit For
			End If
		Next file
		' 如果没有找到匹配的文件，添加到未复制列表
		If Not sheetCopied Then
			failureMessage = failureMessage & ws.Name & vbCrLf
		End If
	Next ws

	' 显示反馈信息
	MsgBox successMessage & vbCrLf & failureMessage

	' 清理对象
	Set file = Nothing
	Set folder = Nothing
	Set fso = Nothing
End Sub