Combining Sheets from Network Location

[jamesmev]

I am currently attempting to combine multiple sheets from a network location into one sheet.

It looks to process everything okay until the actual output of the final combined worksheet.
I am a little lost as to where it is going wrong.
I did remove the file location of where our server is pointing for security purposes.

The overall goal - is the only information the user needs to notate is the path.
The code is reading the network and its path - the "Path" is the subfolder where that file is located.

Sub Auto_Open()Dim path As String
Dim location As String
location = "xxxx file location"
path = InputBox("Enter Bottler", "Select Bottler")
   Filename = Dir(location & "\" & path & "*.xls")
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Do While Filename <> ""
      Workbooks.Open Filename:=path & Filename, ReadOnly:=True
      ActiveWorkbook.Sheets(2).Copy After:=ThisWorkbook.Sheets(1)
      Workbooks(Filename).Close
      Filename = Dir()


   Loop


  Call Combine
  Call Create_single_file
   MsgBox ("Files Merged")
 Application.ScreenUpdating = True
 Application.DisplayAlerts = True
End Sub
Sub Combine()
   Dim J As Long
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False
   Sheets(1).Copy Sheets(1)
   Sheets(1).Name = "Combined"
   For J = 3 To Sheets.Count
      Sheets(J).Range("B1").CurrentRegion.Offset(1).Copy
      Sheets(1).Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues
   Next
   With Sheets(1).UsedRange
      .ColumnWidth = 22
      .RowHeight = 18
      Application.ScreenUpdating = True
      Application.DisplayAlerts = True
      
   End With
End Sub


Sub Create_single_file()
Application.ScreenUpdating = False
Application.DisplayAlerts = False


Dim rs As Worksheet
Dim path As String
Set rs = Worksheets("Combined") 'adjust name as needed
path = InputBox("Enter a file path", "Title Here") ' adjust path as needed"
myFile = path & "Downtime.xlsx"


rs.Cells.Copy


Set NewBook = Workbooks.Add
NewBook.Worksheets("Sheet1").Range("A1").Select ' Special (xlPasteValues)(xlPasteformat)
ActiveSheet.Paste


NewBook.SaveAs Filename:=myFile
ActiveWorkbook.Close
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Any Help?

 

[arthurbr]

Does this link provide any help?

 

[jamesmev]

No sadly it does not. I need to find the error in what I have. It was working and stopped I am not sure what I did wrong and where.

 

[jamesmev]

Sub Auto_Open()Dim path As String
Dim location As String
Dim slash As String
slash = "\"
location = "R:\Site\Public\Down\"
path = InputBox("Enter the Name", "Group Name")
   Filename = Dir(location & path & slash & "*.xlsx")
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Do While Filename <> ""
      Workbooks.Open Filename:=location & path & slash & Filename, ReadOnly:=True
      ActiveWorkbook.Sheets(1).Copy After:=ThisWorkbook.Sheets(1)
      Workbooks(Filename).Close
      Filename = Dir()


Loop


  Call Combine
  Call Create_single_file
   MsgBox ("Files Merged")
 Application.ScreenUpdating = True
 Application.DisplayAlerts = True
End Sub
Sub Combine()
   Dim J As Long
   
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False
   Sheets(1).Copy Sheets(1)
   Sheets(1).Name = "Combined"
   For J = 3 To Sheets.Count
      Sheets(J).Range("A1").CurrentRegion.Offset(1).Copy
      Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues


   Next
   With Sheets(1).UsedRange
      .ColumnWidth = 22
      .RowHeight = 18
      Application.ScreenUpdating = True
      Application.DisplayAlerts = True
      
   End With
End Sub


Sub Create_single_file()
Application.ScreenUpdating = False
Application.DisplayAlerts = False


Dim rs As Worksheet
Dim path As String
Dim location As String
Dim slash As String
slash = "\"
location = "R:\Site\Public\Down\"
Set rs = Worksheets("Combined") 'adjust name as needed
path = InputBox("Enter Name", "Name") ' adjust path as needed"
myFile = location & path & slash & "Downtime.xlsx"


rs.Cells.Copy


Set NewBook = Workbooks.Add
NewBook.Worksheets("Sheet1").Range("A1").Select ' Special (xlPasteValues)(xlPasteformat)
ActiveSheet.Paste


NewBook.SaveAs Filename:=myFile
ActiveWorkbook.Close
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub


I have this working now.. 
however, the data is blank in the main files starting on A3 to H3 - - On Purpose. 
it should start the next line of combining at the first empty row from I. 
Write now it is just overwriting everything until that point.