Fix code to import data

[donthate918]

Okay, I worked through some of my issues from my other post, but I can' get it fine tuned like I want it. Hence the title of this post. It is importing the data as it should, but it will override any data already on the sheet and replace it with the new imported data, and it keep resizing my destination sheet to the source sheet size and I can't figure out how to make it stop. See code here...

Sub MergeAllWorkbooks()
    
    Dim SummarySheet As Worksheet
    Dim FolderPath As String
    Dim NRow As Long
    Dim FileName As String
    Dim WorkBk As Workbook
    Dim SourceRange As Range
    Dim DestRange As Range
    
    ' Add new data to the workbook
    Set SummarySheet = ThisWorkbook.Worksheets("DailyInspectionReports")
    
    ' Modify this folder path to point to the files you want to use.
    FolderPath = "S:\Quality Control\Reports\Inspection\2017\"
    
    ' NRow keeps track of where to insert new rows in the destination workbook.
    NRow = 2
    
    ' Call Dir the first time, pointing it to all Excel files in the folder path.
    FileName = Dir(FolderPath & "*.xl*")
    
    ' Loop until Dir returns an empty string.
    Do While FileName <> ""
        ' Open a workbook in the folder
        Set WorkBk = Workbooks.Open(FolderPath & FileName)
        
        ' Set the cell in column A to be the file name.
        ' Not using this feature.
        ' SummarySheet.Range("A" & NRow).Value = FileName
        
        
        ' Set the source range to be cell through cell or range.
        ' Modify this range for your workbooks.
        ' It can span multiple rows.
        lastRow = WorkBk.Worksheets(1).Cells(Rows.Count, "D").End(xlUp).Row
        Set SourceRange = WorkBk.Worksheets(1).Range("B9:L" & lastRow)
        
        ' Set the destination range to start at column and
        ' KEEP destination size and formatting.
        Set DestRange = ThisWorkbook.Worksheets("DailyInspectionReports").Range("A" & NRow)
        Set DestRange = DestRange.Resize(SourceRange.Rows.Count, SourceRange.Columns.Count)
           
        ' Copy over the values from the source to the destination.
        DestRange.Value = SourceRange.Value
        
        ' Increase NRow so that we know where to copy data next.
        NRow = NRow + DestRange.Rows.Count
        
        ' Close the source workbook without saving changes.
        WorkBk.Close savechanges:=False
        
        ' Use Dir to get the next file name.
        FileName = Dir()
    Loop
    
    ' Call AutoFit on the destination sheet so that all
    ' data is readable.
    ThisWorkbook.Worksheets(1).Columns.Resize
End Sub

 

[RoryA]

Please note I have changed your title as it was neither informative nor appropriate.

I would also suggest you give more detail as to what is wrong with this code.

 

[donthate918]

Okay, he is the codes that do exactly what I want when I run them manually:

Sub MergeAllWorkbooks()
    
    Dim SummarySheet As Worksheet
    Dim FolderPath As String
    Dim NRow As Long
    Dim FileName As String
    Dim WorkBk As Workbook
    Dim SourceRange As Range
    Dim DestRange As Range
    
    ' Create a new workbook and set a variable to the first sheet.
    ' I want to make this the current workbook,sheet 1
    Set SummarySheet = ThisWorkbook.Worksheets("DailyInspectionReports")
    
    ' Modify this folder path to point to the files you want to use.
    FolderPath = "S:\Quality Control\Reports\Inspection\2017"
    
    ' NRow keeps track of where to insert new rows in the destination workbook.
    NRow = 2
    
    ' Call Dir the first time, pointing it to all Excel files in the folder path.
    FileName = Dir(FolderPath & "*.xl*")
    
    ' Loop until Dir returns an empty string.
    Do While FileName <> ""
        ' Open a workbook in the folder
        Set WorkBk = Workbooks.Open(FolderPath & FileName)
        
        ' Set the cell in column A to be the file name.
        ' Not using this feature.
        ' SummarySheet.Range("A" & NRow).Value = FileName
        
        
        ' Set the source range to be cell through cell or range.
        ' Modify this range for your workbooks.
        ' It can span multiple rows.
        lastRow = WorkBk.Worksheets(1).Cells(Rows.Count, "D").End(xlUp).Row
        Set SourceRange = WorkBk.Worksheets(1).Range("B9:L" & lastRow)
        
        ' Set the destination range to start at column and
        ' be the same size as the source range.
        ' I also want the destination sheet to stay the same size and formatting.
        Set DestRange = ThisWorkbook.Worksheets("DailyInspectionReports").Range("A" & NRow)
        Set DestRange = DestRange.Resize(SourceRange.Rows.Count, SourceRange.Columns.Count)
           
        ' Copy over the values from the source to the destination.
        DestRange.Value = SourceRange.Value
        
        ' Increase NRow so that we know where to copy data next.
        NRow = NRow + DestRange.Rows.Count
        
        ' Close the source workbook without saving changes.
        WorkBk.Close savechanges:=False
        
        ' Use Dir to get the next file name.
        FileName = Dir()
    Loop
    
    ' Call AutoFit on the destination sheet so that all
    ' data is readable.
    ThisWorkbook.Worksheets(1).Columns.AutoFit
    

End Sub

Sub SaveFileAs()

 Dim strPath As String
 Dim strFolderPath As String

    strFolderPath = "S:\Quality Control\Reports\Daily Batch Files\Inspection\"

    strPath = strFolderPath & "Daily Inspection Report Summary" & "-" & Format(Now, "mm-dd-yyyy-hh_mm")
    
    ActiveWorkbook.SaveAs FileName:=strPath
    
End Sub

But when I run this .vbs I get an error:91

dim eApp
set eApp = GetObject("S:\Quality Control\Reports\Daily Inspection Report Summary.xlsm")
eApp.Application.Run "'Daily Inspection Report Summary.xlsm'!MergeAllWorkbooks"
eApp.Application.Run "'Daily Inspection Report Summary.xlsm'!SaveFileAs"
set eApp = nothing

I want to use task scheduler to run this task but can't get past the error. Please help.

 

[donthate918]

I update my post, sorry for the title, just frustrated.

 

[donthate918]

The debug takes me to this line:
ActiveWorkbook.SaveAs FileName:=strPath

 

[Joe4]

Re-posted here: https://www.mrexcel.com/forum/excel-questions/1026253-progress-has-been-made-but-now-im-stuck.html