По-долу е процедурата. Само там където имаш

firstWS = "A"
secondWS = "B"

замени A и B с имената на двата листа, които искаш да копираш

' Кодът започва тук

Sub CopyFilesInDir()

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


firstWS = "A"
secondWS = "B"

Set MyNewFile = Workbooks.Add



Set MyWS = MyNewFile.Worksheets.Add
MyWS.Name = secondWS

Set MyWS = MyNewFile.Worksheets.Add
MyWS.Name = firstWS


MyFileName = Dir(MyDir, 7)



Do While MyFileName <> ""
MyFile = MyDir & MyFileName

Set wb = Workbooks.Open(MyFile)

a = True
B = True




On Error Resume Next

wb.Worksheets(firstWS).Activate

If Err <> 0 Then
a = False
MsgBox ("В този файл няма лист " & firstWS & ". Затварям файла без копиране.")
wb.Close
End If

If a Then
wb.Worksheets(secondWS).Activate
If Err <> 0 Then
B = False
MsgBox ("В този файл няма лист " & secondWS & "Затварям файла без копиране.")
wb.Close
End If

On Error GoTo 0

If a And B Then
Application.ScreenUpdating = False
LastRow = wb.Worksheets(firstWS).Range("A65536").End(xlUp).Row
LastRow1 = MyNewFile.Worksheets(firstWS).Range("A65536").End(xlUp).Row
If LastRow1 > 1 Then LastRow1 = LastRow1 + 1

MyRange = "1:" & LastRow

wb.Worksheets(firstWS).Rows(MyRange).Copy

MyNewFile.Worksheets(firstWS).Rows(LastRow1).PasteSpecial


LastRow = wb.Worksheets(secondWS).Range("A65536").End(xlUp).Row
LastRow1 = MyNewFile.Worksheets(secondWS).Range("A65536").End(xlUp).Row
If LastRow1 > 1 Then LastRow1 = LastRow1 + 1

MyRange = "1:" & LastRow



wb.Worksheets(secondWS).Rows(MyRange).Copy

MyNewFile.Worksheets(secondWS).Rows(LastRow1).PasteSpecial

Application.ScreenUpdating = True

wb.Close


End If
End If


MyFileName = Dir()



Loop

Worksheets(secondWS).Activate
Cells(1, 1).Activate

Worksheets(firstWS).Activate
Cells(1, 1).Activate

Do
fName = Application.GetSaveAsFilename
Loop Until fName <> False

If Right(fName, 4) <> ".xls" Then fName = fName & ".xls"
MyNewFile.SaveAs Filename:=fName

End Sub

' Кодът свършва тук

Съдържаниет е скрито
Влезте за да го видите