Страницы: 1
RSS
Добавление столбца макросом по условию
 
Добрый день, форумчане!
Перебрал все, что смог найти, но переделать под свои нужды не получилось (а может плохо искал)... В общем прошу помощи... Необходимо сравнить столбцы по содержимому строк Лист1 G1:AK1 и Лист2 G18:AK18 (по факту - дни месяца). И если, допустим, на Лист2 есть столбец с указанным значением 2 (между 1 и 3), а в Лист1 - нет, то нужно добавить столбец между значениями 1 и 3 листа1 (можно абсолютно пустой). Это нужно для простого копирования значений с Лист1 на Лист2. Думал про формулы переноса по условию (ВПР и схожие), но добиться желаемого результата не получилось. Решил, что проще скопировать, но уперся в количество столбцов. На Лист1 они могут меняться (допустим списания небыло в этот день и софт просто не покажет это число), а форма (Лист2) железная и утвержденная... Привязку лучше сделать к названию листа (т.к. таких листов будет 9 пар из 27 листов книги и их положение меняется в процессе работы других макросов)... Буду крайне благодарен за помощь, т.к. уже дня 3 ломаю голову над решением этой задачи.
 
Код
Sub AddColumns()
    Dim r1 As Range
    Set r1 = Sheets("Лист1").Range("G1")
    
    Dim r2 As Range
    Set r2 = Sheets("Лист2").Range("G18:AK18")
    
    Dim x2 As Long
    Dim c2 As Range
    For Each c2 In r2.Cells
        x2 = x2 + 1
        If Not IsEqual(r1.Cells(1, x2).Value, c2.Value) Then
            AddColumn r1.Cells(1, x2), IIf(x2 = 1, xlFormatFromRightOrBelow, xlFormatFromLeftOrAbove)
            r1.Cells(1, x2).Value = GetVal(c2.Value)
        End If
    Next
End Sub

Private Function IsEqual(s1 As String, s2 As String) As Boolean
    If Left(s1, 1) = "0" Then
        IsEqual = Right(s1, Len(s2)) = s2
    Else
        IsEqual = s1 = s2
    End If
End Function

Private Function GetVal(s1 As String) As String
    GetVal = Right("'0" & s1, 3)
End Function

Private Sub AddColumn(cl As Range, lXlInsertFormatOrigin As XlInsertFormatOrigin)
    cl.EntireColumn.Insert Shift:=xlToRight, CopyOrigin:=lXlInsertFormatOrigin
End Sub
 
Цитата
написал:
на Лист2 есть столбец с указанным значением 2 (между 1 и 3), а в Лист1 - нет, то нужно добавить столбец между значениями 1 и 3 листа1 (можно абсолютно пустой). Это нужно для простого копирования значений с Лист1 на Лист2.
Что-то я не понял зачем добавлять столбцы в Лист1? Застолбите железно дни месяца и простым поиском по условию заполняйте таблицу данными с Лист2.  
 
МатросНаЗебре, то, что нужно!!!! Спасибо огромное! Работает (как минимум в файле-образце). Дальше разберусь что к чему и куда прописать. 3 дня голову ломал... Еще раз спасибо!
 
BodkhiSatva, Как вариант, но тогда формулу нужно будет прописывать все тем же макросом (изначально этих листов в файле нет и они создаются в процессе формирования). Плюс строк может быть от 2-х до "N"... В общем либо я что-то недопонимаю, либо проще иметь макрос (например от МатросНаЗебре), который просто вставит в нужное место недостающие столбцы и далее перенести строки в другую таблицу (также последовательно запустившимся макросом). Но, за наводку спасибо).  
 
МатросНаЗебре, все работает как надо, столбцы добавляет, даже если нет нескольких подряд - добавляет. Единственный затык, если не хватает столбца со значением 01. Там добавляется сразу 2 (один пустой, а второй со значением 01)... Есть возможность поправить не в ущерб остальному коду?  
 
Код
'v2
Sub AddColumns()
    Dim r1 As Range
    Set r1 = Sheets("Лист1").Range("G1").Offset(0, -1)
    
    Dim r2 As Range
    Set r2 = Sheets("Лист2").Range("G18:AK18")
    
    Dim x2 As Long
    x2 = 1
    Dim c2 As Range
    For Each c2 In r2.Cells
        x2 = x2 + 1
        If Not IsEqual(r1.Cells(1, x2).Value, c2.Value) Then
            AddColumn r1.Cells(1, x2), IIf(x2 = 2, xlFormatFromRightOrBelow, xlFormatFromLeftOrAbove)
            r1.Cells(1, x2).Value = GetVal(c2.Value)
        End If
    Next
End Sub

Private Function IsEqual(s1 As String, s2 As String) As Boolean
    If Left(s1, 1) = "0" Then
        IsEqual = Right(s1, Len(s2)) = s2
    Else
        IsEqual = s1 = s2
    End If
End Function

Private Function GetVal(s1 As String) As String
    GetVal = Right("'0" & s1, 3)
End Function

Private Sub AddColumn(cl As Range, lXlInsertFormatOrigin As XlInsertFormatOrigin)
    cl.EntireColumn.Insert Shift:=xlToRight, CopyOrigin:=lXlInsertFormatOrigin
End Sub
Цитата
написал:
Есть возможность поправить не в ущерб остальному коду?  
Добавление десятка символов не будем считать ощутимым ущербом.
 
МатросНаЗебре, Благодарствую! Теперь все работает.
Страницы: 1
Наверх