Макрос сравнения двух баз и переноса данных (главная база на сетевом ресурсе)

[crn0]

Доброго времени суток! Просьба помочь с макросом. Суть проблемы:
Есть база, расположенна на сетевом ресурсе, в которую нужно макросом перенести данные из баз сотрудников, базы сотрудников на рабочих местах. Макрос должен открыть базу сотрудника и перенести из нее определенные данные. Возникла проблема, если делаем прямую ссылку на базу сотрудника то все работает, если же выбор производим через окно, то данные не переносятся. Заранее спасибо!

Function GetFilePath(Optional ByVal Title As String = "Âûáåðèòå ôàéë äëÿ îáðàáîòêè", _
Optional ByVal InitialPath As String = "c:\", _
Optional ByVal FilterDescription As String = "Êíèãè Excel", _
Optional ByVal FilterExtention As String = "*.xlsm*") As String
InitialPath
On Error Resume Next
With Application.FileDialog(msoFileDialo gOpen)
.ButtonName = "Âûáðàòü": .Title = Title: .InitialFileName = InitialPath
.Filters.Clear: .Filters.Add FilterDescription, FilterExtention
If .Show <> -1 Then Exit Function
GetFilePath = .SelectedItems(1): PS = Application.PathSeparator
End With
End Function

Sub Main()

Dim i As Long, x As Range: Application.ScreenUpdating = False
Dim sh As Worksheet, WB As Workbook

Filename$ = GetFilePath("Âûáåðèòå ôàéë Excel", "c:\", "*.xlsm")
If Filename$ = "" Then Exit Sub
Application.ScreenUpdating = False

ThisWorkbook.Sheets(1).Activate

Set sh = ActiveSheet

Set WB = Workbooks.Open(Filename$)
With WB.Sheets(1)
ActiveSheet.Unprotect ("1")

For i = 1 To Cells(Rows.Count, 5).End(xlUp).Row
Set x = .[M:M].Find(Trim(Cells(i, 5)))
If Not x Is Nothing Then Cells(i, 6) = .Cells(x.Row, 4)
If Not x Is Nothing Then Cells(i, 7) = .Cells(x.Row, 7)
If Not x Is Nothing Then Cells(i, 3) = .Cells(x.Row, 16)
If Not x Is Nothing Then Cells(i, 15) = .Cells(x.Row, 17)
Next: End With

End Sub

[IgorGO]

эту строку

ThisWorkbook.Sheets(1).Activate

поместите перед циклом For

[crn0]

Спасибо, помогло)