Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Копирование данных по выбору флажков из элементов управления - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Копирование данных по выбору флажков из элементов управления (Макросы/Sub)
Копирование данных по выбору флажков из элементов управления
Заяц6628 Дата: Четверг, 25.05.2023, 07:57 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 24
Репутация: 0 ±
Замечаний: 0% ±

Добрый день!
Пожалуйста помогите решить мини задачу, есть две одинаковые таблицы, одна заполнена данными, вторя нет, вот нужно чтобы значения из одной таблицы копировались в другую, а какие данные нужно скопировать это определяет выставленный флажок из элементов управления, наглядно задачу в файле указала, код там есть, он он не верный.
К сообщению приложен файл: zadacha.xlsm (20.1 Kb)
 
Ответить
СообщениеДобрый день!
Пожалуйста помогите решить мини задачу, есть две одинаковые таблицы, одна заполнена данными, вторя нет, вот нужно чтобы значения из одной таблицы копировались в другую, а какие данные нужно скопировать это определяет выставленный флажок из элементов управления, наглядно задачу в файле указала, код там есть, он он не верный.

Автор - Заяц6628
Дата добавления - 25.05.2023 в 07:57
Апострофф Дата: Четверг, 25.05.2023, 08:30 | Сообщение № 2
Группа: Проверенные
Ранг: Обитатель
Сообщений: 444
Репутация: 122 ±
Замечаний: 0% ±

Excel 1997
Заяц6628, для начала исправьте в Вашем коде С(рус) на C(eng).
[vba]
Код
xSheet.Range("С3:D3 ").Copy
[/vba]
Да и пробел лучше убрать на всякий случай...


Сообщение отредактировал Апострофф - Четверг, 25.05.2023, 08:31
 
Ответить
СообщениеЗаяц6628, для начала исправьте в Вашем коде С(рус) на C(eng).
[vba]
Код
xSheet.Range("С3:D3 ").Copy
[/vba]
Да и пробел лучше убрать на всякий случай...

Автор - Апострофф
Дата добавления - 25.05.2023 в 08:30
Заяц6628 Дата: Четверг, 25.05.2023, 11:07 | Сообщение № 3
Группа: Пользователи
Ранг: Новичок
Сообщений: 24
Репутация: 0 ±
Замечаний: 0% ±

Это не помогло решить задачу
 
Ответить
СообщениеЭто не помогло решить задачу

Автор - Заяц6628
Дата добавления - 25.05.2023 в 11:07
Апострофф Дата: Четверг, 25.05.2023, 11:17 | Сообщение № 4
Группа: Проверенные
Ранг: Обитатель
Сообщений: 444
Репутация: 122 ±
Замечаний: 0% ±

Excel 1997
А я про, что не надо предлагать ребусы с подменой букв.
Это не ускоряет решение проблемы.
 
Ответить
СообщениеА я про, что не надо предлагать ребусы с подменой букв.
Это не ускоряет решение проблемы.

Автор - Апострофф
Дата добавления - 25.05.2023 в 11:17
Заяц6628 Дата: Четверг, 25.05.2023, 13:41 | Сообщение № 5
Группа: Пользователи
Ранг: Новичок
Сообщений: 24
Репутация: 0 ±
Замечаний: 0% ±

Исправила, помогите пожалуйста решить задачу :help:
К сообщению приложен файл: 6636599.xlsm (19.9 Kb)
 
Ответить
СообщениеИсправила, помогите пожалуйста решить задачу :help:

Автор - Заяц6628
Дата добавления - 25.05.2023 в 13:41
Апострофф Дата: Четверг, 25.05.2023, 14:16 | Сообщение № 6
Группа: Проверенные
Ранг: Обитатель
Сообщений: 444
Репутация: 122 ±
Замечаний: 0% ±

Excel 1997
На каждый флажок назначьте этот макрос.
[vba]
Код
Sub ФлажокX_тык()
Dim SH As Shape
Range("J2:L4").Value = Range("B2:D4").Value
For Each SH In ActiveSheet.Shapes
  If SH.Type = msoFormControl Then
    If SH.TopLeftCell.Column = 1 Then
      If SH.DrawingObject.Value <> 1 Then
        Range("J1:L1").Offset(SH.TopLeftCell.Row - 10).ClearContents
      End If
    ElseIf SH.TopLeftCell.Column = 4 Then
      If SH.DrawingObject.Value <> 1 Then
        Range("I2:I4").Offset(, SH.TopLeftCell.Row - 10).ClearContents
      End If
    End If
  End If
Next SH
End Sub
[/vba]
К сообщению приложен файл: zadacha_ap.xlsm (24.3 Kb)
 
Ответить
СообщениеНа каждый флажок назначьте этот макрос.
[vba]
Код
Sub ФлажокX_тык()
Dim SH As Shape
Range("J2:L4").Value = Range("B2:D4").Value
For Each SH In ActiveSheet.Shapes
  If SH.Type = msoFormControl Then
    If SH.TopLeftCell.Column = 1 Then
      If SH.DrawingObject.Value <> 1 Then
        Range("J1:L1").Offset(SH.TopLeftCell.Row - 10).ClearContents
      End If
    ElseIf SH.TopLeftCell.Column = 4 Then
      If SH.DrawingObject.Value <> 1 Then
        Range("I2:I4").Offset(, SH.TopLeftCell.Row - 10).ClearContents
      End If
    End If
  End If
Next SH
End Sub
[/vba]

Автор - Апострофф
Дата добавления - 25.05.2023 в 14:16
Serge_007 Дата: Четверг, 25.05.2023, 14:32 | Сообщение № 7
Группа: Админы
Ранг: Местный житель
Сообщений: 16475
Репутация: 2748 ±
Замечаний: ±

Excel 2016
Ещё вариант (одним макросом): [vba]
Код
Sub Заяц6628()
Dim VR As Range, HR As Range, Vi&, Hi&
    For Each VR In Range("a12:a14")
        If VR Then Vi = VR.Row - 10
            For Each HR In Range("d12:d14")
                If HR Then
                    Hi = HR.Row - 10
                    If Vi <> 0 Then Cells(Vi, Hi).Offset(0, 8) = Cells(Vi, Hi)
                End If
        Next HR
    Next VR
End Sub
[/vba]
К сообщению приложен файл: 20230525_zajac6628.xls (52.0 Kb)


ЮMoney:41001419691823 | WMR:126292472390
 
Ответить
СообщениеЕщё вариант (одним макросом): [vba]
Код
Sub Заяц6628()
Dim VR As Range, HR As Range, Vi&, Hi&
    For Each VR In Range("a12:a14")
        If VR Then Vi = VR.Row - 10
            For Each HR In Range("d12:d14")
                If HR Then
                    Hi = HR.Row - 10
                    If Vi <> 0 Then Cells(Vi, Hi).Offset(0, 8) = Cells(Vi, Hi)
                End If
        Next HR
    Next VR
End Sub
[/vba]

Автор - Serge_007
Дата добавления - 25.05.2023 в 14:32
Заяц6628 Дата: Четверг, 25.05.2023, 14:44 | Сообщение № 8
Группа: Пользователи
Ранг: Новичок
Сообщений: 24
Репутация: 0 ±
Замечаний: 0% ±

Спасибо огромное, все работает, я счастлива безмерно!!!))) :heart:
 
Ответить
СообщениеСпасибо огромное, все работает, я счастлива безмерно!!!))) :heart:

Автор - Заяц6628
Дата добавления - 25.05.2023 в 14:44
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Копирование данных по выбору флажков из элементов управления (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!