Excel Browsing a folder and Automating Data Entry into a default template

Viewed 571

I been reading up codes available on the net from various sources and have debug with self-taught programming to make it work but I'm having difficulty proceeding on.

As you can see, it comes from a source. Browsing a folder & reading the files works fine with the code, I need to copy values from this folder & paste it into the default template as assigned in the code & save the file with with a default format and alongside values from a cell(O1) & (O11) assign in the code.

Saved format of files

As you can see, is not saved as xlsx and neither is it saving with the values from cell specified.

Next, automating data entry to assigned field. Only first 3 files are able to copy exactly what I want. The rest inputs wrong data, as shown in the image below. Additionally, I also need to copy values from cell N15:O83 read from files in folder, into template Column AA & AB starting from row 6 respectively.

Thanks in advance for any assistance provided.

Sample Source File Data To Extract Correct Automation Correct Automation Wrong Automation Wrong Automation

Macro Code

Sub LoopAllExcelFilesInFolder()
'PURPOSE: To loop through all Excel files in a user specified folder and             perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com

Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim InstID As String
Dim InstDate As Date
Dim InstBR As String




'Optimize Macro Speed
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual

'Retrieve Target Folder Path From User
  Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

With FldrPicker
  .Title = "Select A Target Folder"
  .AllowMultiSelect = False
    If .Show <> -1 Then GoTo NextCode
    myPath = .SelectedItems(1) & "\"
End With

'In Case of Cancel
NextCode:
  myPath = myPath
  If myPath = "" Then GoTo ResetSettings

    'Target File Extension (must include wildcard "*")
  myExtension = "*.xls*"

  'Target Path with Ending Extention
  myFile = Dir(myPath & myExtension)

'Loop through each Excel file in folder
  Do While myFile <> ""
'Set variable equal to opened workbook
  Set wb = Workbooks.Open(Filename:=myPath & myFile)

'Ensure Workbook has opened before moving on to next line of code
  DoEvents

'Input Code Here

  InstID = Range("O1")
  InstDate = Range("O11")
  InstBR = "Base Reading"

  wb.Worksheets(1).Range("B15:E83").Copy
  Workbooks.Add template:="C:\Users\PC1\Desktop\Daily data file\Inc\TestTemplate.xlsx"
  Sheets(ActiveSheet.Index + 1).Activate
  If Err.Number <> 0 Then Sheets(1).Activate
  Range("M6").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

    Range("E6:F76") = InstID
    Range("K6:K76") = InstDate
    Range("J6") = InstBR

ChDir ("C:\Users\PC\Desktop\Daily data file\Inc\INC22001 - Copy\Test Save") ' Directory you need to save the file as xlsm
Filename = ("Test_Data_ ") & Range("O1").Value & ";" &     Range("O11").Value
ActiveWorkbook.SaveAs Filename:=Filename, FileFormat:=xlOpenXMLWorkbook

'Save and Close Workbook
  wb.Close SaveChanges:=True

'Ensure Workbook has closed before moving on to next line of code
  DoEvents

'Get next file name
  myFile = Dir
  Loop

'Message Box when tasks are completed
  MsgBox "Task Complete!"

ResetSettings:
  'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub
3 Answers

This looks problematic

Filename = ("Test_Data_ ") & Range("O1").Value & ";" &     Range("O11").Value
ActiveWorkbook.SaveAs Filename:=Filename, FileFormat:=xlOpenXMLWorkbook

you need to add

& ".xlsx"

to the end of the top line to correctly form the workbook filename.

As per the previous answer, you will need to give your file an extension. But also, you are referencing your Ranges O1 and O11 softly (meaning your not specifying a sheet). If these values need to come from the file you are opening, I would reference them explicitly with wb.Worksheets(1).Range("O1").Value. By the looks of it, you are inadvertently getting these values from the target sheet (see cell O11 in screenshot 2 and your fourth file down in screenshot 1).

I would also be very cautious about putting a raw date in a filename. You would be better with a datestamp: Filename = "Test_Data_ " & InstID & ";" & Format(InstDate,"YYYYMMDD") & ".xlsx"

Hi Please correct me if I'm wrong. Okay here's the thing that I understand based on your explanation.

First you have a Template (wbTemplate), and then a set of other workbooks that you need to open and pre-format it based on the template given then save it on your target path.

You need to practice in setting all your objects dynamically.

I put comments on every line so you may understand how this works.

{

 Sub LoopAllExcelFilesInFolder()
 'PURPOSE: To loop through all Excel files in a user specified folder and             perform a set task on them
 'SOURCE: www.TheSpreadsheetGuru.com

 Dim wbTemplate As Workbook, wbSourceFile As Workbook
 Dim wsTemplate As Worksheet, wsSourceFile As Worksheet
 Dim SourceFileEndRow As Long, TemplateEndRow As Long
 Dim myPath As String, myFile As String 'This is where the Source File      located
 Dim myExtension As String
 Dim FldrPicker As FileDialog
 Dim InstID As String
 Dim InstDate As Date
 Dim InstBR As String
 Dim targetPath As String 'Set this to where you want to save all the output files

 Set wbTemplate = ThisWorkbook
 Set wsTemplate = ThisWorkbook.Sheets(1) ' Input the Index no. of your      Template, or much better to rename it based on the Name of the Template Tab
 targetPath = "C:\Users\Enrerol\Desktop\Tester\TargetPath\" 'Set where you want to save your Output File
 'Optimize Macro Speed
   Application.ScreenUpdating = False
   Application.EnableEvents = False
   Application.Calculation = xlCalculationManual

 'Retrieve Target Folder Path From User
   Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

 With FldrPicker
   .Title = "Select A Target Folder"
   .AllowMultiSelect = False
     If .Show <> -1 Then GoTo NextCode
     myPath = .SelectedItems(1) & "\"
 End With

 'In Case of Cancel
 NextCode:
   myPath = myPath
   If myPath = "" Then GoTo ResetSettings

     'Target File Extension (must include wildcard "*")
   myExtension = "*.xls*"

   'Target Path with Ending Extention
   myFile = Dir(myPath & myExtension)

 'Loop through each Excel file in folder
   Do While myFile <> ""
 'Set variable equal to opened workbook
   Set wbSourceFile = Workbooks.Open(Filename:=myPath & myFile) ' Set our      SourceFile
   Set wsSourceFile = wbSourceFile.Worksheets(1) 'Set the Worksheet that we      are copying
 'Ensure Workbook has opened before moving on to next line of code
   DoEvents

 'Input Code Here

   InstID = wsSourceFile.Range("O1")
   InstDate = wsSourceFile.Range("O11")
   InstBR = "Base Reading"
 SourceFileEndRow = wsSourceFile.Range("B" & Rows.Count).End(xlUp).Row '      This to  make sure that you have a dynamic range; it will get the last row used      of the Source File
   wsSourceFile.Range("B15:E" & SourceFileEndRow).Copy      Destination:=wsTemplate.Range("M6")
 TemplateEndRow = wsTemplate.Range("M" & Rows.Count).End(xlUp).Row 'We will      get the last used row of our Destination Column
   wsTemplate.Range("E6:F" & TemplateEndRow) = InstID
   wsTemplate.Range("K6:K" & TemplateEndRow) = InstDate
   wsTemplate.Range("J6") = InstBR

 Filename = ("Test_Data_") & InstID & "_" & Format(InstDate, "m_d_yyyy") '      You need to change this, because there will be an error on your existing format.      Specially the instdate is Formated as "dd/mm/yyyy"
 Application.DisplayAlerts = False 'We will need to stop the prompting of      the excel application
 wbTemplate.SaveAs Filename:=targetPath & Filename,      FileFormat:=xlOpenXMLWorkbook
 Application.DisplayAlerts = True 'Reset application Values
 'Save and Close Workbook

 wbSourceFile.Close SaveChanges:=True
 wsTemplate.UsedRange.Delete
 'Ensure Workbook has closed before moving on to next line of code
   DoEvents

 'Get next file name
   myFile = Dir
   Loop

 'Message Box when tasks are completed
   MsgBox "Task Complete!"

 ResetSettings:
   'Reset Macro Optimization Settings
 Application.EnableEvents = True
 Application.Calculation = xlCalculationAutomatic
 Application.ScreenUpdating = True

 End Sub
Related