Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Запись данных из ячеек в список VBA
 
#1
12.01.2022 19:20:33
Всем доброго времени суток! Вопрос такого плана: есть несколько ячеек в которых пользователь меняет данные. нужен макрос, который будет записывать данные из этих ячеек в таблицу на другом листе в столбцы с соответствующими именами в первую пустую строку. Мой код добавляет только значение из первой ячейки. Если указать диапазон, все равно ставит значение из первой ячейки. с циклами я не силен, но думаю мой вопрос можно решить с помощью его. Файл прилагаю. буду благодарен любой помощи.
Код
Sub Журнал()
Dim RK As Range, rCell As Range
    Set RK = Sheets("Список").Range("B7:F400")
          For Each rCell In RK
            If IsEmpty(rCell) Or rCell = 0 Then
                rCell = Sheets("Расшифровка").Range("C5").Value
                Exit For
            End If
        Next
End Sub
Изменено: Сергей - 12.01.2022 19:33:28
 
 
 
#2
12.01.2022 20:03:32
мы тоже будем благодарны любому рассказу о задаче
(не показу макроса, который не делает то, что нужно) а рассказу о задаче:
1. исходные данные тут
2. пользователь вносит что-то вот тут
3. макрос должен сделать вот такие действия
когда из вашего рассказа будут понятны все 3 пункта - можно будет написать макрос, который выполнит то, что вы напишете в п.3
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#3
12.01.2022 21:00:01
, в файле-примере есть и то, что вносит пользователь, и то, что в этих же ячейках изменяется,  и то, что должен выполнить макрос  
 
 
 
#4
12.01.2022 21:36:20
Пробуйте.
 
 
 
#5
13.01.2022 13:25:04
, Работает. СПАСИБО!
 
 
 
#6
13.01.2022 13:29:42
DANIKOLA, а если какое то поле не заполнено то сдвиг
Изменено: Тимофеев - 13.01.2022 13:29:58
 
 
 
#7
13.01.2022 14:32:47
Тимофеев, можно так:
Код
Sub Журнал()
    Dim LastRow As Long, Cell As Range, i As Byte
    Application.ScreenUpdating = False
    
    LastRow = Sheets("Список").Cells(Rows.Count, 2).End(xlUp).Row
    i = 2
    
    For Each Cell In Sheets("Расшифровка").Range("C5:C11")
        If Not IsEmpty(Cell.Value) Then
            Sheets("Список").Cells(LastRow + 1, i).Value = Cell.Value
        End If
        'Добавить строку ниже!
        If Not IsEmpty(Cell.Offset(0, -1)) Then i = i + 1
    Next Cell
    Sheets("Список").Activate
End Sub
 
 
 
#8
13.01.2022 14:41:06
все кроме годен удалить и опять сдвиг
 
 
 
#9
13.01.2022 15:12:31
Посмотрите код:
Код
Sub Журнал()
Dim lastRow  As Long, arr
    ReDim arr(1 To 4)
    arr = Sheets("Расшифровка").Range("C5:C8")
    arr = Application.Transpose(arr)
    ReDim Preserve arr(1 To UBound(arr) + 1)
    arr(5) = Sheets("Расшифровка").Range("C11")
    lastRow = Sheets("Список").Cells(Rows.Count, 2).End(xlUp).Row
    Sheets("Список").Cells(lastRow + 1, 2).Resize(1, UBound(arr)) = arr
End Sub
Изменено: artemkau88 - 13.01.2022 15:12:51
 
 
 
#10
13.01.2022 15:17:18
2 раза выполнить только готов в исходнике - будет перезаписывать поверх
 
 
 
#11
13.01.2022 15:33:21
исправил:
Код
Sub Журнал()
Dim lastRow  As Long, arr
    ReDim arr(1 To 4)
    arr = Sheets("Расшифровка").Range("C5:C8")
    arr = Application.Transpose(arr)
    ReDim Preserve arr(1 To UBound(arr) + 1)
    arr(5) = Sheets("Расшифровка").Range("C11")
    lastRow = 1
    Do Until Application.WorksheetFunction.CountA(Sheets("Список").Range("B7:F400").Rows(lastRow)) = 0
        lastRow = lastRow + 1
    Loop
        Sheets("Список").Range("B7:F400").Rows(lastRow).Resize(1, UBound(arr)) = arr

End Sub
Изменено: artemkau88 - 13.01.2022 15:52:30
 
 
 
#12
13.01.2022 15:40:15
При заполненном Заключение о годности только остальные пустые все попадает в первый столбец журнала
 
 
 
#13
13.01.2022 15:53:32
У меня корректно работает (заполняет при заполненном заключении о годности последний столбец)
Немного подправил код, чтобы считал пустые строки только внутри диапазона в предыдущем сообщении
Изменено: artemkau88 - 13.01.2022 15:53:51
 
 
 
#14
14.12.2022 22:17:07
Всем доброго времени суток! Появилась необходимость в модернизации данного макроса... макрос записывает в список все значения подряд и при выполнении макроса несколько раз в списке могут появиться копии.. Нужно чтобы перед записью происходила проверка на совпадение. Если хотя-бы одна ячейка отличается от всех записей в списке, то записать, если не отличается - не записывать.
 
 
 
Страницы: 1
Наверх