Trouble with copying sheets from closed workbooks

Question

So hopefully yall could help. I've got this VBA i've pieced together, with the goal of

opening up a group of xls files each morning & copying all tabs from all files into a single master workbook.
- Insert the file name that the worksheet came from into the 1st column, & fill that down the active region.
- then, combine multiple sheets that are similar format into a new aggregate sheet (hence the insert filename into col1)
- then delete all the old original sheets

So I've got this VBA that does the file importing, and I have another sub() that does the reformating. The problem I'm running into is that if the workbook has multiple worksheets, the all sheets will get copied, but the filename insert portion only happens on the first worksheet, and it repeats the insert on the first work sheet "i" times, where "i" = the # of sheets in the workbook.

How to get this to be correct, where each sheet gets the filename insert? For example, if there's 3 sheets, they all get copied, but the 1stof3 gets 3 columns with the filename.

Here's what I've got going on:

defining strings and popup user selections. Pops up a directory selection box for user.

Function FileNameFromPath(strFullPath As String) As String

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

End Function

defining strings and popup user selections

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

Main file open/copy script

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

inserts new column @ A, Position1, then copy/paste the filename in row2,col1, then fill that name down the length of rows equal to the length of the data table. — surfer349

jsotola jsotola · Accepted Answer · 2017-09-26T17:52:19

you can use this code to split worksheet

the split point has to be visible, so you cannot set it on a worksheet that is not active

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

Trouble with copying sheets from closed workbooks

2 Answers