Страницы: 1
RSS
Копирование данных из открытой книги с разными названиями, Копирование данных из открытой книги в постоянную книгу в определенный лист, в выделенную ячейку
 
Требуется макрос для копирования данных из одной открытой книги в другую открытую. Книга из которой надо брать данные из определенной ячейки имеет разные названия, но всегда в составе книги один лист "МАРШРУТ". Данные надо копировать данные из ячейки A5 в определенную книгу в определенный лист, в выделенную ячейку и  транспонировать данные диапазона H11: H125 из книги с листом "МАРШРУТ" в диапазон который начинается со следующей ячейки, в которой скопированы данные описанные выше.  
 
С таким требованием Вам нужно обращаться в раздел "Работа".
 
val_kaz,
ну для начала активируем книгу, из которой хотим забрать данные и запускаем макрос (его размещаем в файле, в который копируем данные):
Код
Sub aaa()
ActiveWorkbook.Sheets("МАРШРУТ").Range("A5").Copy ThisWorkbook.Sheets("Определенное название").ActiveCell
ActiveWorkbook.Sheets("МАРШРУТ").Range("H11:H125").Copy
ThisWorkbook.Sheets("Определенное название").Cells(ActiveCell.Row + 1, ActiveCell.Column).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
End Sub


P.S. в 99% случаях без файлов-примеров с желаемым результатом помочь крайне трудно
Изменено: evgeniygeo - 20.05.2024 21:02:00
 
evgeniygeo, Во вложении 2 файла. Нужно чтобы из книги с листом "МАРШРУТ", данные переносились в книгу с листом "КАТАЛОГ" по нажатию кнопки. Данные про которые я описывал в своем сообщении.  
Изменено: val_kaz - 21.05.2024 15:51:49
 
Код
Sub Из_МАРШРУТА_с_любовью()
    Dim shMarsh As Worksheet: Set shMarsh = GetSheet("МАРШРУТ"): If shMarsh Is Nothing Then Exit Sub
    Dim shCatal As Worksheet: Set shCatal = GetSheet("КАТАЛОГ"): If shCatal Is Nothing Then Exit Sub
    
    Dim arr As Variant
    arr = myTranspose(shMarsh.Range("H11:H125"))
    
    shCatal.Parent.Activate
    shCatal.Activate
    With ActiveCell.EntireRow
        .Cells(1, 1).Value = shMarsh.Range("A5").Value
        .Cells(1, 2).Resize(1, UBound(arr, 2)).Value = arr
    End With
    
End Sub

Private Function myTranspose(rr As Range) As Variant
    Dim arr As Variant
    arr = rr.Value
    
    Dim brr As Variant
    ReDim brr(1 To UBound(arr, 2), 1 To UBound(arr, 1))
    
    Dim ya As Long
    Dim xa As Long
    For ya = 1 To UBound(arr, 1)
        For xa = 1 To UBound(arr, 2)
            brr(xa, ya) = arr(ya, xa)
        Next
    Next
    myTranspose = brr
End Function

Private Function GetSheet(sheetName As String) As Worksheet
    Dim sh As Worksheet
    Dim index_wb As Long
    
    On Error Resume Next
    For index_wb = Workbooks.Count To 1 Step -1
        Set sh = Workbooks(index_wb).Worksheets(sheetName)
        If Not sh Is Nothing Then
            Set GetSheet = sh
            Exit For
        End If
    Next
    
    On Error GoTo 0
End Function
 
МатросНаЗебре,  Получилось! Супер! Огромное спасибо!
 
МатросНаЗебре,

А можно чуть усложнить?
1. Чтобы данные копировались не в выделенную ячейку, а в  первую свободную
2. При копировании проверялось есть ли такое же название. Если есть то данные не переносились бы
 
Код
Sub Из_МАРШРУТА_с_любовью()
    Dim shMarsh As Worksheet: Set shMarsh = GetSheet("МАРШРУТ"): If shMarsh Is Nothing Then Exit Sub
    Dim shCatal As Worksheet: Set shCatal = GetSheet("КАТАЛОГ"): If shCatal Is Nothing Then Exit Sub
    
    With shCatal
        If WorksheetFunction.CountIfs(.Columns(1), shMarsh.Range("A5").Value) = 0 Then
            Dim arr As Variant
            arr = myTranspose(shMarsh.Range("H11:H125"))
            
            Dim yc As Long
            yc = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
            .Cells(yc, 1).Value = shMarsh.Range("A5").Value
            .Cells(yc, 2).Resize(1, UBound(arr, 2)).Value = arr
                        
            Application.Goto .Cells(yc, 1)
        End If
    End With
    
End Sub

Private Function myTranspose(rr As Range) As Variant
    Dim arr As Variant
    arr = rr.Value
    
    Dim brr As Variant
    ReDim brr(1 To UBound(arr, 2), 1 To UBound(arr, 1))
    
    Dim ya As Long
    Dim xa As Long
    For ya = 1 To UBound(arr, 1)
        For xa = 1 To UBound(arr, 2)
            brr(xa, ya) = arr(ya, xa)
        Next
    Next
    myTranspose = brr
End Function

Private Function GetSheet(sheetName As String) As Worksheet
    Dim sh As Worksheet
    Dim index_wb As Long
    
    On Error Resume Next
    For index_wb = Workbooks.Count To 1 Step -1
        Set sh = Workbooks(index_wb).Worksheets(sheetName)
        If Not sh Is Nothing Then
            Set GetSheet = sh
            Exit For
        End If
    Next
    
    On Error GoTo 0
End Function

 
МатросНаЗебре, Очень круто! Спасибо.  
Изменено: val_kaz - 22.05.2024 17:33:51
 
Код
Sub Из_МАРШРУТА_с_любовью()
    From_marsh True
End Sub

Sub Из_МАРШРУТА_без_любви()
    From_marsh False
End Sub

Private Sub From_marsh(checkPresence As Boolean)
    Dim shMarsh As Worksheet: Set shMarsh = GetSheet("МАРШРУТ"): If shMarsh Is Nothing Then Exit Sub
    Dim shCatal As Worksheet: Set shCatal = GetSheet("КАТАЛОГ"): If shCatal Is Nothing Then Exit Sub
    
    With shCatal
        If checkPresence Then
            If WorksheetFunction.CountIfs(.Columns(1), shMarsh.Range("A5").Value) > 0 Then Exit Sub
        End If
        
        Dim arr As Variant
        arr = myTranspose(shMarsh.Range("H11:H125"))
        
        Dim yc As Long
        yc = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        .Cells(yc, 1).Value = shMarsh.Range("A5").Value
        .Cells(yc, 2).Resize(1, UBound(arr, 2)).Value = arr
                    
        Application.Goto .Cells(yc, 1)
    End With
End Sub

Private Function myTranspose(rr As Range) As Variant
    Dim arr As Variant
    arr = rr.Value
    
    Dim brr As Variant
    ReDim brr(1 To UBound(arr, 2), 1 To UBound(arr, 1))
    
    Dim ya As Long
    Dim xa As Long
    For ya = 1 To UBound(arr, 1)
        For xa = 1 To UBound(arr, 2)
            brr(xa, ya) = arr(ya, xa)
        Next
    Next
    myTranspose = brr
End Function

Private Function GetSheet(sheetName As String) As Worksheet
    Dim sh As Worksheet
    Dim index_wb As Long
    
    On Error Resume Next
    For index_wb = Workbooks.Count To 1 Step -1
        Set sh = Workbooks(index_wb).Worksheets(sheetName)
        If Not sh Is Nothing Then
            Set GetSheet = sh
            Exit For
        End If
    Next
    
    On Error GoTo 0
End Function
Страницы: 1
Наверх