I have written the following macro. I do not really see it necessary to explain ehat it does, I only need help with a problem - for some reason it does not reach the code after the loop. It does everything exactly as I want it until and into the loop, but does not execute the code after the loop at all. Could anyone be so kind as to take a look at it? Sub CopyFilesInDir() i = 1 Set objShell = CreateObject("Shell.Application") Set objFolder = objShell.BrowseForFolder(0, "Select Folder", 0, 0) If (Not objFolder Is Nothing) Then On Error Resume Next If IsError(objFolder.Items.Item.Path) Then MyDir = _ CStr(objFolder): GoTo Here On Error GoTo 0 If Len(objFolder.Items.Item.Path) > 3 Then MyDir = objFolder.Items.Item.Path & _ Application.PathSeparator Else MyDir = objFolder.Items.Item.Path End If Else: Application.ScreenUpdating = True: End End If Here: Set objFolder = Nothing: Set objShell = Nothing secondWS = "FP_2" Set MyNewFile = Workbooks.Add Set MyWS = MyNewFile.Worksheets.Add MyWS.Name = secondWS MyFileName = Dir(MyDir, 7) Do While MyFileName <> "" MyFile = MyDir & MyFileName Set wb = Workbooks.Open(MyFile) On Error Resume Next If Err <> 0 Then MsgBox (" òîçè ôàéë íÿìà ëèñò " & secondWS & "Çàòâàðÿì ôàéëà áåç êîïèðàíå.") wb.Close End If On Error GoTo 0 wb.Worksheets(secondWS).Activate Application.ScreenUpdating = False i = i + 1 MyNewFile.Worksheets(secondWS).Range("A1") = "Áóëñòàò" MyNewFile.Worksheets(secondWS).Range("B1") = "Èìå" MyNewFile.Worksheets(secondWS).Range("C1") = "Îáîðîò" MyNewFile.Worksheets(secondWS).Range("D1") = "Áðóòíà íîðìà íà ïå÷àëáàòà" MyNewFile.Worksheets(secondWS).Range("E1") = "Äîáàâåíà ñòîéíîñò íà åäèí çàåò" MyNewFile.Worksheets(secondWS).Range("F1") = "Íîðìà íà âúçâðúùàåìîñò íà ÄÌÀ" MyNewFile.Worksheets(secondWS).Range("G1") = "Îáùà çàäëúæíÿëîñò" MyNewFile.Worksheets(secondWS).Range("H1") = "Ïðèõîäè îò èçíîñ" wb.Worksheets(secondWS).Range("I5").Copy MyNewFile.Worksheets(secondWS).Cells(i, 1).PasteSpecial wb.Worksheets(secondWS).Range("C7").Copy MyNewFile.Worksheets(secondWS).Cells(i, 2).PasteSpecial wb.Worksheets(secondWS).Range("J12").Copy MyNewFile.Worksheets(secondWS).Cells(i, 3).PasteSpecial wb.Worksheets(secondWS).Range("J13").Copy MyNewFile.Worksheets(secondWS).Cells(i, 4).PasteSpecial wb.Worksheets(secondWS).Range("J14").Copy MyNewFile.Worksheets(secondWS).Cells(i, 5).PasteSpecial wb.Worksheets(secondWS).Range("J15").Copy MyNewFile.Worksheets(secondWS).Cells(i, 6).PasteSpecial wb.Worksheets(secondWS).Range("J16").Copy MyNewFile.Worksheets(secondWS).Cells(i, 7).PasteSpecial wb.Worksheets(secondWS).Range("J17").Copy MyNewFile.Worksheets(secondWS).Cells(i, 8).PasteSpecial Application.ScreenUpdating = True wb.Close MyFileName = Dir() Loop strPath = Workbooks("OBDanni.xls").Path MsgBox (strPath) MyNewFile.SaveAs strPath & "" & "OBD.xls", _ FileFormat:=xlNormal, _ Password:="", _ WriteResPassword:="", _ ReadOnlyRecommended:=False, _ CreateBackup:=False Etrap: Beep End Sub

Software/Hardware used: