从封闭的工作簿中复制纸张时遇到问题

所以希望大家可以提供帮助。我有这个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

来源

2017-09-25 surfer349

什么是否“填补了活动区域”的意思？ – jsotola

插入新的列@A，位置1，然后在row2，col1中复制/粘贴文件名，然后将该名称填充到等于数据表长度的行的长度。 – surfer349

这是因为你不符合正常的范围内工作表：

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

来源

2017-09-25 20:55:30

我没有看到你在哪里改变'Filename'的值。除非这种情况发生了变化，否则它会一直重复打印该名称。 – dwirony

@dwirony问题是文件名在第三张纸上打印了3次。发生这种情况是因为它是在'ActiveWorksheet'上完成的，因为当它循环时，范围不会被'Sheet.'限定。 –

@Viktor K Ahhh我明白了。我以为他们想在每个页面上使用不同的名称，而不是相同的名称。得到它了。 – dwirony

您可以使用此代码，以分割工作表

分割点必须是可见的，所以你不能把它放在一个工作表是不活跃

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

来源

2017-09-26 17:52:19 jsotola

从封闭的工作簿中复制纸张时遇到问题

回答

相关问题