从closures的工作簿复制工作表时遇到麻烦

所以希望大家可以帮忙。 我有这个VBA我拼凑在一起，目标是

• 每天早晨打开一组xls文件，并将所有文件中的所有选项卡复制到一个主工作簿中。
  • 将工作表来自的文件名插入到第一列中，然后在活动区域​​中填充。
  • 然后，将多个相似格式的工作表合并到一个新的集合工作表（因此插入文件名到col1中）
  • 然后删除所有旧的原始纸张

所以我有这个文件导入的VBA，我有另一个子（）重新格式化。 我遇到的问题是，如果工作簿有多个工作表，所有工作表将被复制，但文件名插入部分只发生在第一个工作表，并重复插入第一张工作表“我”次，其中“我”=工作簿中的工作表数量。

如何让这是正确的，每个表获取文件名插入？ 例如，如果有3张纸，它们全部被复制，但是1的3将得到具有文件名的3列。

以下是我正在做的事情：

定义string并popup用户select。 popup用户的目录select框。

Function FileNameFromPath(strFullPath As String) As String FileNameFromPath = Right(strFullPath, Len(strFullPath) - InStrRev(strFullPath, "\")) End Function 

定义string并popup用户select

 Function GetFolder(strpath As String) As String Dim fldr As FileDialog Dim sItem As String Set fldr = Application.FileDialog(msoFileDialogFolderPicker) With fldr .Title = "Select a Folder" .AllowMultiSelect = False .InitialFileName = strpath If .Show <> -1 Then GoTo NextCode sItem = .SelectedItems(1) End With NextCode: GetFolder = sItem & "\" Set fldr = Nothing End Function 

主文件打开/复制脚本

 Sub CombineFiles() 'Define variables Dim fso As New Scripting.FileSystemObject Dim i As Integer, rngData As Range Dim errcheck As Integer Dim strpath As String, Title As String 'Path for folder to default to strpath = "c:\directory" 'Open window to select folder Set afolder = fso.GetFolder(GetFolder(strpath)) strpath = afolder + "\" 'This keeps the screen from updating until the end, makes the macro run faster Application.ScreenUpdating = False Application.DisplayAlerts = False 'This makes the file read-only during changes With ActiveSheet If .ProtectContents Then .Unprotect Else .Protect "", True, True, True, True End With 'Cycles through every file in the folder with .xls* extension Filename = Dir(strpath & "*.xls*") Do While Filename <> "" Workbooks.Open Filename:=strpath & Filename, ReadOnly:=True 'Loops through each sheet in file errcheck = 0 For Each Sheet In ActiveWorkbook.Sheets If Sheet.Visible = xlSheetVisible Then If ActiveSheet.AutoFilterMode = True Then Range("A1").AutoFilter End If Columns(1).Insert 'inserts new col @ A for spec# Cells(1, 1).Value = "Filename" 'Range("A2").AutoFill Destination:=Range("A2:A" & Range("B" & Rows.Count).End(xlUp).Row) Range("A2:A" & Cells(Rows.Count, "B").End(xlUp).Row).Value = Filename 'inserts name @ A2 and fills down length of colB If ActiveSheet.AutoFilterMode = False Then Range("A1").AutoFilter End If Columns.AutoFit Set rngData = Range("A1").CurrentRegion On Error Resume Next: Sheet.Copy After:=ThisWorkbook.Sheets(1) ActiveWindow.FreezePanes = False Rows("2:2").Select ActiveWindow.FreezePanes = True End If Next Sheet Workbooks(Filename).Close False Filename = Dir() Loop Application.ScreenUpdating = True End Sub 

Answer 1

发生这种情况是因为您没有正确限定范围的工作表：

 For Each Sheet In ActiveWorkbook.Sheets If Sheet.Visible = xlSheetVisible Then If ActiveSheet.AutoFilterMode = True Then Range("A1").AutoFilter End If Sheet.Columns(1).Insert 'inserts new col @ A for spec# Sheet.Cells(1, 1).Value = "Filename" 'Range("A2").AutoFill Destination:=Range("A2:A" & Range("B" & Rows.Count).End(xlUp).Row) Sheet.Range("A2:A" & Sheet.Cells(Sheet.Rows.Count, "B").End(xlUp).Row).Value = Filename 'inserts name @ A2 and fills down length of colB If ActiveSheet.AutoFilterMode = False Then Range("A1").AutoFilter End If Sheet.Columns.AutoFit Set rngData = Range("A1").CurrentRegion On Error Resume Next: Sheet.Copy After:=ThisWorkbook.Sheets(1) ActiveWindow.FreezePanes = False Sheet.Rows("2:2").Select ActiveWindow.FreezePanes = True End If Next Sheet 

我不完全确定rngData是否在Sheet所以检查是否必须是合格的。 AutoFilter行也一样。 对于FreezePanes：

 Sheet.Activate with ActiveWindow if .FreezePanes then .FreezePanes = False .SplitRow = 1 .FreezePanes = True end with 

Answer 2

您可以使用此代码来拆分工作表

分割点必须是可见的，所以你不能将它设置在不活动的工作表上

  ActiveWindow.ScrollIntoView 1, 1, 1, 1 ' show top of worksheet ActiveWindow.SplitRow = 1 ActiveWindow.FreezePanes = True