從封閉的工作簿中複製紙張時遇到問題

Question

所以希望大家可以提供幫助。我有這個VBA我已經拼湊在一起，

• 開放一組XLS的目標文件中的每個早晨&複製所有文件中的所有標籤爲一個單一的主簿。
  • 將工作表來自的文件名插入到第1列中，&將活動區域填充下來。
  • 然後，合併多張類似於格式轉換成一個新的聚集表（因此插入到文件名COL1）
  • 然後刪除所有原來的老片

所以我有這個執行文件導入的VBA，以及另一個執行重新格式化的子（）。我遇到的問題是，如果工作簿有多個工作表，則所有工作表都將被複制，但文件名插入部分只發生在第一個工作表上，並且會在第一張工作表「i」上重複插入，其中「我」=工作簿中的工作表數量。

如何讓這是正確的，其中每個工作表獲取文件名插入？ 例如，如果有3張紙，它們全部被複制，但1st的3獲得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