0

I'm getting stuck atm with an excel vba macro.
I like to do the following.

A File is lying on a Network Drive. Ie.

H:\Excel Files\LocationA\

In this folder are many Excel Files all are the same with diffrent data.
I need to read out 2 Cell Values and put them in a new Excel File.
I need the Cel value not the formula or format.

So the Excel Files are Closed

My Script below is working but. It crashes during the process i think in case of opening and close the excel Files. Maybe there are some latency Problems on the Network drive.

Further there are 2 other Locations

H:\Excel Files\LocationB\
H:\Excel Files\LocationC\

If i have finaly working the LocationA I like to copy the loop for the other 2 Location. So maybe i need more Variables.

Sub LoopAllExcelFilesInFolder()


Dim wb As Workbook
Dim myPathLiestal As String
Dim myPathMuttenz As String
Dim myPathReinach As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog

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




myPathLocationA = "H:\Excel\LocationA\"


'Message Box when tasks are completed
  MsgBox "Die Daten werden verarbeitet. Bitte haben sie einen Moment geduld"

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

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

'Set Dest Path with Ending Extention
 Set wsDest = Workbooks("Test.xlsm").Worksheets("2019")

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

    DestLastRowA = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Row
    'DestLastRowB = wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Offset(1).Row

    'Mitarbeiter Namen werden aus der Zelle Q1 kopiert
        wb.Worksheets("2019").Range("Q1").Copy
        wsDest.Range("A" & DestLastRowA).PasteSpecial xlPasteValues

    'Mitarbeiter Stundenkontigent werden aus der Zelle W8 kopiert
        wb.Worksheets("2019").Range("W8").Copy
        wsDest.Range("B" & DestLastRowA).PasteSpecial xlPasteValues

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

     Application.CutCopyMode = False 'Clear Clipboard


    '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
Til
  • 5,150
  • 13
  • 26
  • 34
sanktis
  • 1
  • 1
    Welcome to stack overflow. Please try to give details on any errors you encounter when asking a question. For example, with "crashes during the process" ... Does the script exit with an error code? Does the script hang/freeze and you have to force quit? – dijksterhuis Aug 21 '19 at 15:25
  • Hi dijksterhuis Thanks for your reply. I have now solved the multi location issue with 3 vba scripts and update Button on each Workspace. I have copied all the sourc files and the new *.xlsm to my local D:\ drive. The Script is running there well. On the network drive the Script for the location with 5-15 Files are running also ok. On the Main Site 50 + Excelsheets the Execl is Crashing "Microsoft excel is trying to recover your information" The excel reopens in a recovery mode for the file. It realy seams the delay between the Workstation and the File Server. – sanktis Aug 21 '19 at 15:52

0 Answers0