Страницы: 1
RSS
Копирование макросом ячейки с формулой из одного файла и в ставка во все файлы в папке
 
Добрый день, друзья, подскажите пожалуйста. Копирую из "файла1" ячейку с "Лист1" ячейкаВ5  (в этой ячейке формула = Лист2!Н5+Лист2!Н6). вставляю во все файлы в папке на лист1 в ячейку В5. вставляется, но формула вставляется со связями на "файл1". Как убрать связь? Если копировать формулу только с листа1, то во всех файлах вставляется формула, а если копировать ячейку, в которой формула ссылается на лист2, то вставляется со связью на данный файл. Файлы все с одинаковыми именами листов.
Изменено: natalia875 - 06.06.2024 15:26:44
 
Код
Sub Copy()
    Dim FS As Object, KATALOG As Object, FILE As Object, MASSIV As Object
    Dim katal As String
    Dim Rng As Range
    Dim wb As Workbook
       katal = GetFolderPath("Выбрать каталог", ThisWorkbook.Path)
       If katal = "" Then Exit Sub
    Set FS = CreateObject("Scripting.FileSystemObject")
    Set KATALOG = FS.GetFolder(katal)
    Set MASSIV = KATALOG.Files
    
    For Each FILE In MASSIV
       Set wb = Workbooks.Open(Filename:=FILE)        
       If IsSheetExist(wb, "Лист1") Then
            wb.Sheets("Лист1").Select
            Set Rng = ThisWorkbook.Worksheets("Лист1").Range("B5")
            Rng.Copy Destination:=wb.Sheets("Лист1").Range("B5")
            wb.Save
        End If
        wb.Close
    Next
    End Sub
Private Function IsSheetExist(ByVal wb As Workbook, ByVal sName As String) As Boolean
    On Error Resume Next
    With wb.Worksheets(CStr(sName)): End With
    IsSheetExist = (Err = 0)
    Err.Clear
End Function
Function GetFolderPath(Optional ByVal Title As String = "Выбрать папку", _
                       Optional ByVal InitialPath As String = "c:\") As String
    Dim PS As String: PS = Application.PathSeparator
    With Application.FileDialog(msoFileDialogFolderPicker)
        If Not Right$(InitialPath, 1) = PS Then InitialPath = InitialPath & PS
        .ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath
        If .Show <> -1 Then Exit Function
        GetFolderPath = .SelectedItems(1)
        If Not Right$(GetFolderPath, 1) = PS Then GetFolderPath = GetFolderPath & PS
    End With
Изменено: natalia875 - 07.06.2024 10:34:34
 
Код из #2 нерабочий. Не хватает, как минимум, Set wb = ...
Код
Sub myCopy()
    Dim FS As Object, KATALOG As Object, FILE As Object, MASSIV As Object
    Dim katal As String
    Dim Rng As Range
    Dim wb As Workbook
       katal = GetFolderPath("Выбрать каталог", ThisWorkbook.Path)
       If katal = "" Then Exit Sub
    Set FS = CreateObject("Scripting.FileSystemObject")
    Set KATALOG = FS.GetFolder(katal)
    Set MASSIV = KATALOG.Files
    
    For Each FILE In MASSIV
        If IsSheetExist(wb, "Лист1") Then
            wb.Sheets("Лист1").Select
            Set Rng = ThisWorkbook.Worksheets("Лист1").Range("B5")
            Rng.Copy Destination:=wb.Sheets("Лист1").Range("B5")
            wb.Sheets("Лист1").Range("B5").Formula = Rng.Formula
            wb.Save
        End If
        wb.Close
    Next
    End Sub
Private Function IsSheetExist(ByVal wb As Workbook, ByVal sName As String) As Boolean
    On Error Resume Next
    With wb.Worksheets(CStr(sName)): End With
    IsSheetExist = (Err = 0)
    Err.Clear
End Function
Function GetFolderPath(Optional ByVal Title As String = "Выбрать папку", _
                       Optional ByVal InitialPath As String = "c:\") As String
    Dim PS As String: PS = Application.PathSeparator
    With Application.FileDialog(msoFileDialogFolderPicker)
        If Not Right$(InitialPath, 1) = PS Then InitialPath = InitialPath & PS
        .ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath
        If .Show <> -1 Then Exit Function
        GetFolderPath = .SelectedItems(1)
        If Not Right$(GetFolderPath, 1) = PS Then GetFolderPath = GetFolderPath & PS
    End With
End Function
 
МатросНаЗебре, Приветствую вас!
Пишу с телефона, я конечно извиняюсь а у вас где в коде Set wb = ... ? В вашем коде вы тоже используете данную переменную (wb) но нигде не определена.
 
Добрый день, подправила, но все равно ссылки остаются на первый файл, из которого копируем.
Изменено: natalia875 - 07.06.2024 10:26:16
 
Вот что копируем, и то что вставляется связь со ссылкой на файл. Как вставить формулу, чтобы ссылок не было.
 
Цитата
написал:
а у вас где в коде Set wb = ... ?
У меня тоже нет. Я внёс правки в абстрактный код, предполагая, что это часть рабочего кода.
 
Цитата
написал:
У меня тоже нет. Я внёс правки в абстрактный код, предполагая, что это часть рабочего кода.
Внесла в код (сообщение #2)
 
Лучше внесите в код (сообщение #3).
 
Цитата
написал:
Лучше внесите в код (сообщение #3).
Я внесла изменение у себя в сообщение #3, и показала фото, что связь остается после выполнения макроса.Если копируем обычную формулу, то она вставляется без связи. А если в формуле указан расчет с другого листа, то при вставке остается связь.
Изменено: natalia875 - 07.06.2024 11:42:01
 
В коде написано для ячейки B5.
А у вас MH...
 
Цитата
написал:
В коде написано для ячейки B5.А у вас MH...
Это я знаю, просто в задании упростила.
 
Приложите оба файла.
Страницы: 1
Наверх