Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Заполнение табеля по кнопке, Перенос данных из диапазона в ближайший свободный столбик
 
#1
27.05.2024 11:15:25
Добрый день. Имеется файл с 2 вкладками: Личный состав и табель. В личном составе меняется расположение людей в текущий момент, командировка, в депо, больничный и т.д., в табеле проставляем данные по расположению на конец рабочего дня. В примере указано 3 небольшие бригады, на деле в рабочем файле их гораздо больше, 400 человек. В табель добавлен столбик (AS) копирующий текущее расположение специалистов из вкладки Личный состав. Каждый вечер нужно вручную выделять весь этот столбик и копировать в нужный день.
Прошу помочь с макросом, который по нажатию кнопки будет сам копировать данный столбик в нужный день (в ближайший свободный день).
PS: позиции специалистов в табеле и личном составе соответствуют друг другу.
Изменено: Юрий Греков - 27.05.2024 11:17:24
 
 
 
#2
27.05.2024 11:30:52
Код
Sub КопироватьСтолбец()
    Dim shTab As Worksheet
    Set shTab = Sheets("Табель ")
    With shTab
        Dim rUp As Range
        Set rUp = .Range("AS3")
        
        Dim yy As Long
        yy = .Cells(.Rows.Count, rUp.Column).End(xlUp).Row
        If yy < rUp.Row Then Exit Sub
        
        Dim arr As Variant
        arr = .Range(rUp, .Cells(yy, rUp.Column)).Value
        
        Dim rTarg As Range
        Set rTarg = .Range("AL3")
        
        Do
            If rTarg.Value <> "" Then
                Set rTarg = rTarg.Cells(1, 2)
                Exit Do
            End If
            Set rTarg = rTarg.Offset(0, -1)
            If rTarg.Column = 1 Then Exit Do
        Loop
        
        With rTarg
            .Resize(UBound(arr, 1)).Value = arr
            Application.Goto .Cells
        End With
    End With
End Sub
 
 
 
#3
27.05.2024 13:21:47
Все отлично, работает, спасибо, маленький нюанс, как поправить макрос, что бы он не весь столбик AS копировал, а в диапазоне от 4 до 428 строки включительно. Это постоянный размер таблицы, за пределами другие данные.
Изменено: Юрий Греков - 27.05.2024 13:30:49
 
 
 
#4
27.05.2024 14:04:26
Для фиксированного диапазона AS4:AS428.
Код
Sub КопироватьСтолбец()
    Dim shTab As Worksheet
    Set shTab = Sheets("Табель ")
    With shTab
        Dim rSource As Range
        Set rSource = .Range("AS4:AS428")
        
        Dim rTarget As Range
        Set rTarget = rSource.Offset(0, -1)
        
        Do
            If rTarget.Cells(1, 1).Value <> "" Then
                Set rTarget = rTarget.Offset(0, 1)
                Exit Do
            End If
            Set rTarget = rTarget.Offset(0, -1)
            If rTarget.Column = Columns("G:G").Column Then Exit Do
        Loop
        
        rTarget.Value = rSource.Value
        Application.Goto rTarget
    End With
End Sub
 
 
 
#5
27.05.2024 16:17:12
Второй макрос не срабатывает(( Скидывая образец непосредственно рабочего файла, может в примере не верно указал что то.
 
 
 
#6
27.05.2024 16:21:42
Код
Sub КопироватьСтолбец()
    Dim shTab As Worksheet
    Set shTab = Sheets("Табель ")
    With shTab
        Dim rSource As Range
        Set rSource = .Range("AS4:AS428")
        
        Dim rTarget As Range
        Set rTarget = rSource.Offset(0, -2)
        
        Do
            If rTarget.Cells(1, 1).Value <> "" Then
                Set rTarget = rTarget.Offset(0, 1)
                Exit Do
            End If
            Set rTarget = rTarget.Offset(0, -1)
            If rTarget.Column = Columns("G:G").Column Then Exit Do
        Loop
        
        rTarget.Value = rSource.Value
        Application.Goto rTarget
    End With
End Sub
Макрос ищет непустой столбец слева для выполнения требования:
Цитата
написал:
в ближайший свободный день
 
 
 
#7
27.05.2024 16:54:08
В моем случае табель заполнен по 26 число(столбик AG), с 27 по 31 пустые столбики (c AH по AL), столбики AM, AN и AO имеют данные, но при нажатии на кнопку, данные копируются в столбик AO, замещая все, что там есть :(, хотя как я понял, макрос должен искать непустой  столбик именно после столбика G, но это получается AH должен использовать, но он игнорирует его почему-то.    
 
 
 
#8
27.05.2024 17:40:31
Код
Sub КопироватьСтолбец()
    Dim shTab As Worksheet
    Set shTab = Sheets("Табель ")
    With shTab
        Dim rSource As Range
        Set rSource = .Range("AS4:AS428")
        
        Dim rTarget As Range
        Set rTarget = Intersect(rSource.EntireRow, .Columns("H:H"))
        
        Do
            If rTarget.Cells(1, 1).Value = "" Then
'                Set rTarget = rTarget.Offset(0, 1)
                Exit Do
            End If
            Set rTarget = rTarget.Offset(0, 1)
            If rTarget.Column > Columns("AL:AL").Column Then Exit Sub
        Loop
        
        rTarget.Value = rSource.Value
        Application.Goto rTarget
    End With
End Sub
 
 
 
#9
27.05.2024 18:12:07
Да, вот теперь все норм работает! Спасибо огромное!
 
 
 
#10
28.05.2024 09:20:08
Цитата
написал:
вот теперь все норм работает!
Ну тогда попробуйте такой вариант  :D
Добавился макрос очистки столбца.
Код
Option Explicit

Private Const source_range = "AS4:AS428"
Private Const target_range = "H:AL"
Private Const sheet_name = "Табель "

Sub КопироватьСтолбец()
    ColumnJob "copy"
End Sub

Sub ОчиститьСтолбец()
    ColumnJob "clear"
End Sub

Private Sub ColumnJob(sMode As String)
    Dim rTarget As Range
    Set rTarget = GetTargetRange()
    If rTarget Is Nothing Then Exit Sub
    
    Select Case sMode
    Case "copy"
        Set rTarget = GetEmptyColumn(rTarget)
        If rTarget Is Nothing Then Exit Sub
        rTarget.Value = rTarget.Parent.Range(source_range).Value
    Case "clear"
        Set rTarget = GetNonEmptyColumn(rTarget)
        If rTarget Is Nothing Then Exit Sub
        rTarget.ClearContents
    End Select

    Application.Goto rTarget
End Sub
    
Private Function GetEmptyColumn(rTarget As Range) As Range
    Dim arr As Variant
    arr = rTarget.Rows(1).Value
    
    Dim xx As Long
    For xx = 1 To UBound(arr, 2)
        If arr(1, xx) = "" Then
            Set GetEmptyColumn = rTarget.Columns(xx)
            Exit Function
        End If
    Next
End Function

Private Function GetNonEmptyColumn(rTarget As Range) As Range
    Dim arr As Variant
    arr = rTarget.Rows(1).Value
    
    Dim xx As Long
    For xx = UBound(arr, 2) To 1 Step -1
        If arr(1, xx) <> "" Then
            Set GetNonEmptyColumn = rTarget.Columns(xx)
            Exit Function
        End If
    Next
End Function

Private Function GetSourceRange() As Range
    On Error Resume Next
    Set GetSourceRange = Sheets(sheet_name).Range(source_range)
    On Error GoTo 0
End Function
    
Private Function GetTargetRange() As Range
    On Error Resume Next
    With Sheets(sheet_name)
        Set GetTargetRange = Intersect(.Range(target_range), GetSourceRange.EntireRow)
    End With
    On Error GoTo 0
End Function
 
 
 
Страницы: 1
Наверх