Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Копирование данных из открытой книги с разными названиями, Копирование данных из открытой книги в постоянную книгу в определенный лист, в выделенную ячейку
 
#1
20.05.2024 17:21:16
Требуется макрос для копирования данных из одной открытой книги в другую открытую. Книга из которой надо брать данные из определенной ячейки имеет разные названия, но всегда в составе книги один лист "МАРШРУТ". Надо копировать данные из ячейки A5 в определенную книгу в определенный лист, в выделенную ячейку и  транспонировать данные диапазона H11: H125 из книги с листом "МАРШРУТ" в диапазон который начинается со следующей ячейки, в которой скопированы данные описанные выше.  
Изменено: val_kaz - 19.09.2024 18:23:10
 
 
 
#2
20.05.2024 20:34:24
С таким требованием Вам нужно обращаться в раздел "Работа".
 
 
 
#3
20.05.2024 21:00:43
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
 
 
 
#4
21.05.2024 15:50:55
evgeniygeo, Во вложении 2 файла. Нужно чтобы из книги с листом "МАРШРУТ", данные переносились в книгу с листом "КАТАЛОГ" по нажатию кнопки. Данные про которые я описывал в своем сообщении.  
Изменено: val_kaz - 21.05.2024 15:51:49
 
 
 
#5
21.05.2024 16:09:47
Код
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
 
 
 
#6
21.05.2024 16:54:27
МатросНаЗебре,  Получилось! Супер! Огромное спасибо!
 
 
 
#7
22.05.2024 13:46:01
МатросНаЗебре,

А можно чуть усложнить?
1. Чтобы данные копировались не в выделенную ячейку, а в  первую свободную
2. При копировании проверялось есть ли такое же название. Если есть то данные не переносились бы
 
 
 
#8
22.05.2024 14:01:17
Код
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
 
 
 
#9
22.05.2024 17:17:42
МатросНаЗебре, Очень круто! Спасибо.  
Изменено: val_kaz - 22.05.2024 17:33:51
 
 
 
#10
22.05.2024 17:38:42
Код
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
 
 
 
#11
01.08.2024 17:07:17
МатросНаЗебре,

А как этот макрос заставить работать обратно? Получил данные потом выбрал строку в первом столбце нажал кнопку и данные обратно перенести
 
 
 
#12
24.01.2025 01:28:40
Цитата
написал:
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
Ак как такой макрос осуществить но из открытой книги в закрытую? Вот пытаюсь даже с двумя активными книгами сделать, но данные почему то переносит на 501 строку, хотя в макросе прописано в первую свободную. Из книги "Ввод данных" с листа "Данные" в книгу "Тест" лист "ЗАКАЗЫ". И это происходит из за того что в первом столбце формула в ячейках
Изменено: val_kaz - 24.01.2025 02:38:01
 
 
 
#13
24.01.2025 09:48:10
val_kaz, Кто вам мешает определить последнюю ячейку в другой колонке (B), например так:
Код
        Dim yc      As Long
        yc = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
или так:
Код
        Dim yc      As Long
        yc = .Columns("B").Find(what:="*", _
                LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False).Row + 1
По мимо копи - паст надо ещё вникать в код, если вы заинтересованы в этом. Если конечно-же вам удобнее при каждом чихе бегать на форум то другое дело и по другому будут к вам относится.
Изменено: MikeVol - 24.01.2025 09:54:50 (Дополнил ответ)
 
 
 
#14
24.01.2025 14:56:47
Цитата
написал:
val_kaz , Кто вам мешает определить последнюю ячейку в другой колонке (B), например так:Код        Dim yc      As Long
       yc = .Cells(.Rows.Count, 2).End(xlUp).Row + 1или так:Код        Dim yc      As Long
       yc = .Columns("B").Find(what:="*", _
               LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False).Row + 1По мимо копи - паст надо ещё вникать в код, если вы заинтересованы в этом. Если конечно-же вам удобнее при каждом чихе бегать на форум то другое дело и по другому будут к вам относится.
У меня написан макрос который добавляет в свободные ячейки с 3 по 11 колонку. Но он не добавляет потому что в колонке 1 на все 500 строк есть формула. Если удалить формулы из 1-й колонки то с 3 по 11 колонку данные заполняются как надо.  Есть решение о том как переносить все данные из последней ячейки  1-й колонки в пустую ячейку этой колонки? Ваш код тут вообще не причем. У меня и так определяет последнюю ячейку нужных колонок и вносит все отлично если бы не заполненный ячейки именно формулой в 1-й колонке  
Изменено: val_kaz - 24.01.2025 15:46:42
 
 
 
#15
24.01.2025 15:41:10
Цитата
val_kaz написал:
данные почему то переносит на 501 строку, хотя в макросе прописано в первую свободную.
???
Цитата
val_kaz написал:
У меня и так определяет последнюю ячейку нужных колонок и вносит все отлично если бы не заполненный ячейки именно формулой в 1-й колонке
Вы читаете через строку?
 
 
 
#16
24.01.2025 15:48:47
Цитата
написал:
val_kaz , Кто вам мешает определить последнюю ячейку в другой колонке (B), например так:
Что мне дает определение последней ячейки в колонке B? Она мне вообще не нужна)  
Изменено: val_kaz - 24.01.2025 15:49:21
 
 
 
#17
24.01.2025 20:27:11
Цитата
val_kaz написал:
Что мне дает определение последней ячейки в колонке B?
М-да...
Цитата
val_kaz написал:
Вот пытаюсь даже с двумя активными книгами сделать, но данные почему то переносит на 501 строку, хотя в макросе прописано в первую свободную.
 
 
 
#18
26.01.2025 18:39:30
Цитата
написал:
М-да..
я нахожу последнюю строку в колонке 3. Какая разница в моем случае в колонке 2 находить или в 3? При любом раскладе если в колонке 1 формулы на 500 строк то данные в остальные колонки могут только наполняться начина с 501 строки
Вот макрос. Все работает когда в 1 колонке нет формулы. Если можете помочь то помогите с макросом который вставляет в первую пустую строку данные из предыдущей.
Код
Sub Наполнение_данными()
    Dim shMarsh As Worksheet: Set shMarsh = GetSheet("Данные"): If shMarsh Is Nothing Then Exit Sub
    Dim shCatal1 As Worksheet: Set shCatal1 = GetSheet("ЗАКАЗЫ"): If shCatal1 Is Nothing Then Exit Sub
    
    Application.ScreenUpdating = False
     
    With shCatal1
     
    Dim yc As Long
            yc = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
            .Cells(yc, 3).Value = shMarsh.Range("A3").Value
            '.Cells(yc, 4).Value = shMarsh.Range("B3").Value
            '.Cells(yc, 5).Value = shMarsh.Range("C3").Value
            '.Cells(yc, 6).Value = shMarsh.Range("D3").Value
            '.Cells(yc, 7).Value = shMarsh.Range("E3").Value
            '.Cells(yc, 8).Value = shMarsh.Range("F3").Value
            '.Cells(yc, 9).Value = shMarsh.Range("G3").Value
            '.Cells(yc, 10).Value = shMarsh.Range("H3").Value
            '.Cells(yc, 11).Value = shMarsh.Range("I3").Value
            
            
            End With
                              
    
End Sub
Изменено: val_kaz - 26.01.2025 18:45:14
 
 
 
#19
26.01.2025 19:38:11
Цитата
val_kaz написал:
yc = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
Оно и видно как вы это делаете
Цитата
val_kaz написал:
я нахожу последнюю строку в колонке 3.
Я пас, не доходит до вас...
 
 
 
Страницы: 1
Читают тему
Наверх