Изменить источник данных с другого листа

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Изменить источник данных с другого листа (Макросы/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

Ответить

Pelena

Дата: Пятница, 17.03.2023, 22:02 | Сообщение № 2

Группа: Админы

Ранг: Местный житель

Сообщений: 19403

Репутация: 4555 ±

Замечаний: ±

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

Ответить

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)

Страница 1 из 1
1