0

我被一个excel vba宏卡住了atm。
我喜欢做以下事情。

文件位于网络驱动器上。IE。

H:\Excel Files\LocationA\

在这个文件夹中有许多 Excel 文件，它们都与不同的数据相同。
我需要读出 2 个单元格值并将它们放入一个新的 Excel 文件中。
我需要 Cel 值而不是公式或格式。

所以 Excel 文件已关闭

我下面的脚本正在运行，但是。它在我认为打开和关闭excel文件的过程中崩溃。网络驱动器上可能存在一些延迟问题。

此外还有 2 个其他位置

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

如果我最终完成了 LocationA，我想复制其他 2 个位置的循环。所以也许我需要更多的变量。

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
4

0 回答 0