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

Вход

Регистрация

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

 

= Мир MS Excel/Изменить источник данных с другого листа - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Изменить источник данных с другого листа (Макросы/Sub)
Изменить источник данных с другого листа
Dimchec Дата: Пятница, 17.03.2023, 21:33 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 5
Репутация: 0 ±
Замечаний: 20% ±

2016
Прошу помощи есть две таблицы на одном листе на первой таблицы выставляется расписание а вторая база с которой берутся данные для расписания, требуется сменить источник данных с другого листа, но так как код писал ГЕНИЙ то я ни хрена там не понял и походу куда только не писал ни кто не может. но не ужели код работает только на одном листе. если кто сможет помогите! Хотя бы в крайнем случаи расписать что куда а то набор букв в коде вообще не могу понять.

[vba]
Код
Sub Schedule()
Dim t, r&, rw&, m, p, a, c&, s&, i&
m = [d1]: p = [d2]: If IsEmpty(m) Or IsEmpty(p) Then Exit Sub
t = [L1].CurrentRegion: [b5:f29].ClearContents
For r = 2 To UBound(t)
If t(r, 1) = m And t(r, 2) = p Then
If t(r, 5) Like "Полная*" Then c = 1: s = 1 Else c = 2: s = 2
If t(r, 5) Like "Три*" Then c = 1
rw = Round((t(r, 4) - 1 / 3) * 48, 0) + 5
a = Cells(rw, 2).Resize(1, 5)
For i = c To 5 Step s: a(1, i) = t(r, 3): Next
Cells(rw, 2).Resize(1, 5) = a
End If
Nex
End Sub
[/vba]
К сообщению приложен файл: raspisanie.xlsm (24.9 Kb)


DIMCHEC

Сообщение отредактировал Dimchec - Пятница, 17.03.2023, 21:35
 
Ответить
СообщениеПрошу помощи есть две таблицы на одном листе на первой таблицы выставляется расписание а вторая база с которой берутся данные для расписания, требуется сменить источник данных с другого листа, но так как код писал ГЕНИЙ то я ни хрена там не понял и походу куда только не писал ни кто не может. но не ужели код работает только на одном листе. если кто сможет помогите! Хотя бы в крайнем случаи расписать что куда а то набор букв в коде вообще не могу понять.

[vba]
Код
Sub Schedule()
Dim t, r&, rw&, m, p, a, c&, s&, i&
m = [d1]: p = [d2]: If IsEmpty(m) Or IsEmpty(p) Then Exit Sub
t = [L1].CurrentRegion: [b5:f29].ClearContents
For r = 2 To UBound(t)
If t(r, 1) = m And t(r, 2) = p Then
If t(r, 5) Like "Полная*" Then c = 1: s = 1 Else c = 2: s = 2
If t(r, 5) Like "Три*" Then c = 1
rw = Round((t(r, 4) - 1 / 3) * 48, 0) + 5
a = Cells(rw, 2).Resize(1, 5)
For i = c To 5 Step s: a(1, i) = t(r, 3): Next
Cells(rw, 2).Resize(1, 5) = a
End If
Nex
End Sub
[/vba]

Автор - Dimchec
Дата добавления - 17.03.2023 в 21:33
Pelena Дата: Пятница, 17.03.2023, 22:02 | Сообщение № 2
Группа: Админы
Ранг: Местный житель
Сообщений: 19167
Репутация: 4412 ±
Замечаний: ±

Excel 365 & Mac Excel
Если правильно поняла
[vba]
Код
Sub Schedule()
    Dim t, r&, rw&, m, p, a, c&, s&, i&
    Dim otbl As ListObject
    m = [d1]: p = [d2]: If IsEmpty(m) Or IsEmpty(p) Then Exit Sub
    Set otbl = Sheets("База").ListObjects("База_tb")
    t = otbl.DataBodyRange: [b5:f29].ClearContents
    For r = 1 To UBound(t)
        If t(r, 1) = m And t(r, 3) = p Then
            If t(r, 5) Like "Полная*" Then c = 1: s = 1 Else c = 2: s = 2
            If t(r, 5) Like "Три*" Then c = 1
            rw = Round((t(r, 6) - 1 / 3) * 48, 0) + 5
            a = Cells(rw, 2).Resize(1, 5)
            For i = c To 5 Step s: a(1, i) = t(r, 2): Next
            Cells(rw, 2).Resize(1, 5) = a
        End If
    Next
End Sub
[/vba]


"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816
 
Ответить
СообщениеЕсли правильно поняла
[vba]
Код
Sub Schedule()
    Dim t, r&, rw&, m, p, a, c&, s&, i&
    Dim otbl As ListObject
    m = [d1]: p = [d2]: If IsEmpty(m) Or IsEmpty(p) Then Exit Sub
    Set otbl = Sheets("База").ListObjects("База_tb")
    t = otbl.DataBodyRange: [b5:f29].ClearContents
    For r = 1 To UBound(t)
        If t(r, 1) = m And t(r, 3) = p Then
            If t(r, 5) Like "Полная*" Then c = 1: s = 1 Else c = 2: s = 2
            If t(r, 5) Like "Три*" Then c = 1
            rw = Round((t(r, 6) - 1 / 3) * 48, 0) + 5
            a = Cells(rw, 2).Resize(1, 5)
            For i = c To 5 Step s: a(1, i) = t(r, 2): Next
            Cells(rw, 2).Resize(1, 5) = a
        End If
    Next
End Sub
[/vba]

Автор - Pelena
Дата добавления - 17.03.2023 в 22:02
Dimchec Дата: Пятница, 17.03.2023, 22:33 | Сообщение № 3
Группа: Пользователи
Ранг: Прохожий
Сообщений: 5
Репутация: 0 ±
Замечаний: 20% ±

2016
Да спасибо уже и сам тоже разобрался но Вам спасибо что отозвались
Вот мой код
Тоже заработал
В таблице База добавил еще одну колонку перед Месяц

Sub Schedule() ' Расписание'

Dim t, p, m, a As Variant
Dim r, c, rw, s, i As Long

m = Raspis.Range("D1")
p = Raspis.Range("D2")
If IsEmpty(m) Or IsEmpty(p) Then Exit Sub

t = Base.[D1].CurrentRegion
Raspis.Range("B5:F29").ClearContents

For r = 2 To UBound(t)

If t(r, 2) = m And t(r, 4) = p Then

If t(r, 6) Like "Полная*" Then c = 1: s = 1 Else c = 2: s = 2

If t(r, 6) Like "Три*" Then c = 1

rw = Round((t(r, 7) - 1 / 3) * 48, 0) + 5

a = Cells(rw, 2).Resize(2, 6)

For i = c To 5 Step s: a(1, i) = t(r, 3): Next

Cells(rw, 2).Resize(2, 6) = a

End If

Next

Тема закрыта


DIMCHEC

Сообщение отредактировал Dimchec - Пятница, 17.03.2023, 22:37
 
Ответить
СообщениеДа спасибо уже и сам тоже разобрался но Вам спасибо что отозвались
Вот мой код
Тоже заработал
В таблице База добавил еще одну колонку перед Месяц

Sub Schedule() ' Расписание'

Dim t, p, m, a As Variant
Dim r, c, rw, s, i As Long

m = Raspis.Range("D1")
p = Raspis.Range("D2")
If IsEmpty(m) Or IsEmpty(p) Then Exit Sub

t = Base.[D1].CurrentRegion
Raspis.Range("B5:F29").ClearContents

For r = 2 To UBound(t)

If t(r, 2) = m And t(r, 4) = p Then

If t(r, 6) Like "Полная*" Then c = 1: s = 1 Else c = 2: s = 2

If t(r, 6) Like "Три*" Then c = 1

rw = Round((t(r, 7) - 1 / 3) * 48, 0) + 5

a = Cells(rw, 2).Resize(2, 6)

For i = c To 5 Step s: a(1, i) = t(r, 3): Next

Cells(rw, 2).Resize(2, 6) = a

End If

Next

Тема закрыта

Автор - Dimchec
Дата добавления - 17.03.2023 в 22:33
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Изменить источник данных с другого листа (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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