Question

所以希望yall可以提供帮助。我已经将这个VBA拼凑在了一起，目标是

每天早上开放一组xls文件＆amp;将所有文件中的所有选项卡复制到单个主工作簿中。
- 将工作表来自的文件名插入第1列，＆amp;填写活跃区域。
- 然后，将多个相似格式的工作表组合成一个新的聚合工作表（因此将插入文件名插入到col1中）
- 然后删除所有旧的原始工作表

所以我有这个VBA进行文件导入，我有另一个sub（）进行重新格式化。我遇到的问题是，如果工作簿有多个工作表，则所有工作表都将被复制，但文件名插入部分仅在第一个工作表上发生，并且它会在第一个工作表上重复插入＆＃34 ; I＆＃34;时间，地点＆＃34;我＆＃34; =工作簿中的工作表数。

如何使每个工作表获取文件名插入是正确的？例如，如果有3张纸，它们都会被复制，但是1stof3会获得3列文件名。

以下是我发生的事情：

定义字符串和弹出用户选择。弹出用户的目录选择框。

Function FileNameFromPath(strFullPath As String) As String

FileNameFromPath = Right(strFullPath, Len(strFullPath) - InStrRev(strFullPath, "\"))

End Function

定义字符串和弹出用户选择

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

从已关闭的工作簿复制表单时出现问题

2 个答案: