Страницы: 1
RSS
Макрос копирования областей по датам
 
Приветствую! Может у кого завалялся макрос копирования диапазонов в зависимости от дат. Или подскажите как сделать. Нужно что б макрос (по кнопке) в листе me взял дату из ячейки B2 нашел её в листе main и вставил диапазоны C15:R19 и C21:J24 с листа  me в соответствующие дате диапозоны на листе main.
 
Цитата
Олег - написал:
в соответствующие дате диапозоны на листе main.
1. это для вас "соответствующие", а для нас они совсем не соответствующие
2. Вы понимаете, что если скопировать с листа Me диапазон C15:R19 и вставить его в диапазон С13:R19 на листе Main, то все формулы на листе Main в этом диапазоне пропадут? Вам так и надо, чтобы они пропали, или вы это не подразумеваете? Или сохранение формул на листе Main не обязательно, можно копировать весь диапазон сразу? Тогда это легче сделать
3. Чтобы не удалились формулы на листе Main, то с листа Me надо копировать C15:D19, потом G15:H19, потом K15:L19, потом O15:P19. Но и это нельзя сделать, так как у вас ячейка "Кубы" объединены на листе Main (ячейки D16:E16). Если убрать все объединённые ячейки (D:E в кубах), то можно сделать такое копирование по диапазонам, тогда формулы на листе Main останутся нетронутыми.
А так, если основываться только на вашем описании задания, то вот так

Код
Sub Copy_data()
    Dim iDate As Date, Rng As Range, TempRng As Range, n As Long, ShtME As Worksheet, ShtMAIN As Worksheet, StartRow As Long
    
    Set ShtME = Worksheets("me")
    With ShtME
        If IsEmpty(.Range("B2")) Then
            MsgBox "Не указана дата в ячейке В2!", vbExclamation, "Внимание"
            Exit Sub
        End If
        iDate = .Range("B2")
    End With
    
    Set ShtMAIN = Worksheets("main")
    With ShtMAIN
        Set Rng = .Columns(1).Find(iDate, , xlValues, xlWhole)
        If Rng Is Nothing Then
            MsgBox "На листе Main не найдена дата: " & iDate, vbExclamation, "Внимание"
            Exit Sub
        End If
    End With
    
    StartRow = Rng.Row - 1
    
    'копирование диапазонов
    ShtME.Range("C15:R19").Copy
    ShtMAIN.Cells(StartRow, "C").PasteSpecial xlValues
        
    ShtME.Range("C21:J24").Copy
    ShtMAIN.Cells(StartRow, "AF").PasteSpecial xlValues
    
    MsgBox "Данные с листа Me скопированы на лист Main", vbInformation, "Конец"
End Sub
Если удалите все объединённые ячейки у Кубов на листе Main (D:E, H:I, L:M, P:Q), то можно будет использовать такой код
Код
Sub Copy_data1()
    Dim iDate As Date, Rng As Range, TempRng As Range, n As Long, ShtME As Worksheet, ShtMAIN As Worksheet, StartRow As Long
    
    Set ShtME = Worksheets("me")
    With ShtME
        If IsEmpty(.Range("B2")) Then
            MsgBox "Не указана дата в ячейке В2!", vbExclamation, "Внимание"
            Exit Sub
        End If
        iDate = .Range("B2")
    End With
    
    Set ShtMAIN = Worksheets("main")
    With ShtMAIN
        Set Rng = .Columns(1).Find(iDate, , xlValues, xlWhole)
        If Rng Is Nothing Then
            MsgBox "На листе Main не найдена дата: " & iDate, vbExclamation, "Внимание"
            Exit Sub
        End If
    End With
    
    StartRow = Rng.Row - 1
    'копирование диапазонов
    ShtME.Range("C15:D19").Copy
    ShtMAIN.Cells(StartRow, "C").PasteSpecial xlValues
        
    ShtME.Range("G15:H19").Copy
    ShtMAIN.Cells(StartRow, "G").PasteSpecial xlValues
        
    ShtME.Range("K15:L19").Copy
    ShtMAIN.Cells(StartRow, "K").PasteSpecial xlValues
        
    ShtME.Range("O15:P19").Copy
    ShtMAIN.Cells(StartRow, "O").PasteSpecial xlValues
        
    ShtME.Range("C21:J24").Copy
    ShtMAIN.Cells(StartRow, "AF").PasteSpecial xlValues
    
    MsgBox "Данные с листа Me скопированы на лист Main", vbInformation, "Конец"
End Sub
Изменено: New - 13.09.2021 13:19:27
 
New, спасибо, работает. но есть вопросы.
Цитата
New написал:
1. это для вас "соответствующие", а для нас они совсем не соответствующие
здесь не понял претензии, наверное не объяснил нормально где там куда копировать, моя промашка, прошу прощения.
Цитата
New написал:
2. Вы понимаете, что если скопировать с листа Me диапазон C15:R19 и вставить его в диапазон С13:R19 на листе Main, то все формулы на листе Main в этом диапазоне пропадут?
данное выражение исправил функцией SkipBlanks:=True , работает.
Цитата
New написал:
так как у вас ячейка "Кубы" объединены на листе Main
а вот это в теории должно было копироваться функцией xlPasteValuesAndNumberFormats но оно почему-то не работает, можете объяснить почему?
и ещё в коде небольшая ошибка .PasteSpecial xlValue исправил на .PasteSpecial xlValues и код заработал
 
Цитата
Олег - написал:
небольшая ошибка .PasteSpecial xlValue исправил на .PasteSpecial xlValues и код заработал
Странно, что мой Excel с включенной Option explicit пропустил эту опечатку...
 
Цитата
New написал:
Странно, что мой Excel с включенной Option explicit пропустил эту опечатку
не странно, потому что константа xlValue тоже существует. Используется в диаграммах
Изменено: Дмитрий(The_Prist) Щербаков - 13.09.2021 13:27:26
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Спасибо, Дим. При том, я тестировал код, всё копировалось, код работал.
Олег -, вас макрос устраивает? Работает как надо? Всё копируется? Если ещё нужна помочь, то приложите файл Excel с вашим макросом мы посмотрим
Изменено: New - 13.09.2021 13:29:23
 
Цитата
New написал:
я тестировал код, всё копировалось, код работал
вполне вероятно, когда константа 2 не была найдена среди констант для PasteSpecial, был применен тип по умолчанию - все.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Всё нормально спасибо
Страницы: 1
Наверх