Сообщения

Справка это которая через f1 вызывается ? Если да то я там был все по английски и ничего не понятно.

Не понятна вот эта строчка:

Код (vb) Выделить Развернуть

if not rr is nothing then
Это значит что условие выполняется если он ничего не нашел ? Или наоборот  если нашел ? Ото тут что то типа "если нет rr есть ничего тогда".

Если не нашел значение нужное что бы сделал r=i+li

Хм... извините какой уж есть пример как его сделать меньше и понятнее просто не знаю. Если выложить только одну -две строчки то будет не понятно что там вообще происходит.

Здравствуйте. Такой вот вопрос есть два модуля почти одинаковые в одном модуле(nap) условие срабатывает как положено а во втором(yfg) почему то значение находится но все равно срабатывает if err подскажите что не так.

Код (vb) Выделить Развернуть

Sub yfg()
 
    Workbooks.Open ThisWorkbook.Path & "\b.xlsm"
 
    Dim rCell As Range, avArr, li As Long, i As Long, vCriteria
     
    Set ws = Workbooks("b.xlsm").Sheets("B")
    Set ws2 = Workbooks("Ж.xlsm").Sheets("К")
    endrow = ws2.Cells(4, 2).End(xlDown).Row
 
    For i = endrow To 4 Step -1
        li = 0
        If ws2.Cells(i, 1).Interior.Color = ws2.Cells(3, 18).Interior.Color Then GoTo 1
        x = ws2.Cells(i, 2).Value
        ReDim avArr(1 To Rows.Count, 1 To 1)
        vCriteria = x
        With New Collection
            On Error Resume Next
            For Each rCell In ws.Range("C2", ws.Cells(ws.Rows.Count, 3).End(xlUp))
                If rCell = vbNullString Or rCell = "" Then Resume Next
                If rCell.Offset(, -1).Value = vCriteria Then
                    .Add rCell.Value, CStr(rCell.Value)
                    If Err = 0 Then
                        li = li + 1: avArr(li, 1) = rCell.Value
                    Else: Err.Clear
                    End If
                End If
            Next
        End With
        If li Then
            ws2.Rows(i + 1 & ":" & i + li).Insert Shift:=xlDown
            ws2.Cells(i + 1, 2).Resize(li).Value = avArr
            ws2.Range(ws2.Cells(i + 1, 1), ws2.Cells(i + li, 24)).Interior.Color = ws2.Cells(1, 18).Interior.Color
        With ws2
       
             NameX = "Другие"
             NameY = "Другие2"
             RowWs2 = Empty
       
             RowWs2 = ws2.Range(ws2.Cells(i + 1, 2), ws2.Cells(i + li, 2)).Find(What:=NameX, LookIn:=xlFormulas _
                  , LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                  MatchCase:=False, SearchFormat:=False).Row
             If Err Then
                RowWs2 = Empty
                RowWs2 = ws2.Range(ws2.Cells(i + 1, 2), ws2.Cells(i + li, 2)).Find(What:=NameY, LookIn:=xlFormulas _
                     , LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                     MatchCase:=False, SearchFormat:=False).Row
                If Err Then
                   R = i + li
                Else
                   v = .Cells(RowWs2, 2).Value
                   u = .Cells(i + li, 2).Value
                   .Cells(i + li, 2) = v
                   .Cells(RowWs2, 2) = u
                   R = i + li - 1
                End If
             Else
                v = .Cells(RowWs2, 2).Value
                u = .Cells(i + li, 2).Value
                .Cells(i + li, 2) = v
                .Cells(RowWs2, 2) = u
                RowWs2 = Empty
                RowWs2 = ws2.Range(ws2.Cells(i + 1, 2), ws2.Cells(i + li, 2)).Find(What:=NameY, LookIn:=xlFormulas _
                     , LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                     MatchCase:=False, SearchFormat:=False).Row
                If Err Then
                   R = i + li - 1
                Else
                   v = .Cells(RowWs2, 2).Value
                   u = .Cells(i + li - 1, 2).Value
                   .Cells(i + li - 1, 2) = v
                   .Cells(RowWs2, 2) = u
                   R = i + li - 2
                End If
             End If
        End With
        ws2.Sort.SortFields.Clear
        ws2.Sort.SortFields.Add Key:=Range("B:B"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With ws2.Sort
                .SetRange Range(ws2.Cells(i + 1, 2), ws2.Cells(R, 2))
                .Header = xlNo
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
        End With
        End If
1
    Next
       
    Workbooks("b.xlsm").Close 0
   
End Sub


А именно вот этот кусок кода:

Код (vb) Выделить Развернуть

        With ws2
       
             NameX = "Другие"
             NameY = "Другие2"
             RowWs2 = Empty
       
             RowWs2 = ws2.Range(ws2.Cells(i + 1, 2), ws2.Cells(i + li, 2)).Find(What:=NameX, LookIn:=xlFormulas _
                  , LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                  MatchCase:=False, SearchFormat:=False).Row
             If Err Then
                RowWs2 = Empty
                RowWs2 = ws2.Range(ws2.Cells(i + 1, 2), ws2.Cells(i + li, 2)).Find(What:=NameY, LookIn:=xlFormulas _
                     , LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                     MatchCase:=False, SearchFormat:=False).Row
                If Err Then
                   R = i + li
                Else
                   v = .Cells(RowWs2, 2).Value
                   u = .Cells(i + li, 2).Value
                   .Cells(i + li, 2) = v
                   .Cells(RowWs2, 2) = u
                   R = i + li - 1
                End If
             Else
                v = .Cells(RowWs2, 2).Value
                u = .Cells(i + li, 2).Value
                .Cells(i + li, 2) = v
                .Cells(RowWs2, 2) = u
                RowWs2 = Empty
                RowWs2 = ws2.Range(ws2.Cells(i + 1, 2), ws2.Cells(i + li, 2)).Find(What:=NameY, LookIn:=xlFormulas _
                     , LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                     MatchCase:=False, SearchFormat:=False).Row
                If Err Then
                   R = i + li - 1
                Else
                   v = .Cells(RowWs2, 2).Value
                   u = .Cells(i + li - 1, 2).Value
                   .Cells(i + li - 1, 2) = v
                   .Cells(RowWs2, 2) = u
                   R = i + li - 2
                End If
             End If
        End With

Да точно спасибо надо было почитать. Я заходил на эту страницу просмотрел по быстрому и не заметил где про это написано.

Здравствуйте. Подскажите почему не срабатывает такой вариант закрашивания диапазона ?

Код (vb) Выделить Развернуть

Sub nap()
 
    Workbooks.Open ThisWorkbook.Path & "\b.xlsm"
 
    Dim rCell As Range, avArr, li As Long, i As Long, vCriteria
     
    Set ws = Workbooks("b.xlsm").Sheets("B")
    Set ws2 = Workbooks("Ж.xlsm").Sheets("К")
    endrow = ws2.Cells(4, 2).End(xlDown).Row
 
    For i = endrow To 4 Step -1
        li = 0
        x = ws2.Cells(i, 2).Value
        ReDim avArr(1 To Rows.Count, 1 To 1)
        vCriteria = x
        With New Collection
            On Error Resume Next
            For Each rCell In ws.Range("B2", ws.Cells(ws.Rows.Count, 2).End(xlUp))
                If rCell = vbNullString Or rCell = "" Then Resume Next
                If rCell.Offset(, -1).Value = vCriteria Then
                    .Add rCell.Value, CStr(rCell.Value)
                    If Err = 0 Then
                        li = li + 1: avArr(li, 1) = rCell.Value
                    Else: Err.Clear
                    End If
                End If
            Next
        End With
        If li Then
            ws2.Rows(i + 1 & ":" & i + li).Insert Shift:=xlDown
            ws2.Cells(i + 1, 2).Resize(li).Value = avArr
            ws2.Range(Cells(i + 1, 1), Cells(i + li, 24)).Interior.Color = ws2.Cells(1, 17).Interior.Color
        End If
        With ws2
             For t = i + 1 To i + li
                 v = .Cells(t, 2).Value
                 If v = "Другие" Then
                    u = .Cells(i + li, 2).Value
                    .Cells(i + li, 2) = v
                    .Cells(t, 2) = u
                    R = i + li - 1
                 Else
                    R = i + li
             End If
        Next
        End With
            ws2.Sort.SortFields.Clear
            ws2.Sort.SortFields.Add Key:=Range("B:B"), _
                SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            With ws2.Sort
                .SetRange Range(Cells(i + 1, 2), Cells(R, 2))
                .Header = xlNo
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
        Next
       
    Workbooks("b.xlsm").Close 0
   
End Sub


Интересует вот эта строка может что то не так написал ?

Код (vb) Выделить Развернуть

ws2.Range(Cells(i + 1, 1), Cells(i + li, 24)).Interior.Color = ws2.Cells(1, 17).Interior.Color

Код проходит все выполняется но ничего не закрашивается.

Alexander88, попробовал написанные варианты и еще на одном форуме написано что =1 можно поставить ничего из этого не помогло.

RAN , такой вариант от части работает но перемешивает строки и во 2 столбце съезжают залитые строки со своих мест. И еще он очень долго выполняется.

Думаю может их просто перекрашивать потом будет проще ? но вот такой вариант почему то не срабатывает:

Код (vb) Выделить Развернуть

Workbooks("Ж.xlsm").Sheets("К").Range(Cells(i + 1, 1), Cells(i + li, 24)).Interior.Color = Workbooks("Ж.xlsm").Sheets("К").Cells(1, 17).Interior.Color
[gmod]Цитируйте при необходимости. [/gmod]

Не понял что нужно сделать. Мне надо что бы обычные пустые строки и без заливки добавились в указанном месте.

Никак не могу найти как добавить строки что бы они не были отформатированы и закрашены как соседние.

Код (vb) Выделить Развернуть

Workbooks("Ж.xlsm").Sheets("К").Rows(i + 1 & ":" & i + li).Insert Shift:=xlDown

При таком добавление строки закрашиваются как верхняя и формат получают такой же как у верхней.

Учту и запомню на будущее. Спасибо.

Понятно.

Спасибо. Я не забыл просто не знал что их там надо ставить.

Здравствуйте.

Код (vb) Выделить Развернуть

Sub nap()
 
    Workbooks.Open ThisWorkbook.Path & "\B.xlsm"
     
    Dim rCell As Range, avArr, li As Long, i As Long, vCriteria
     
    endrow = Workbooks("Ж.xlsm").Sheets("К").Cells(4, 2).End(xlDown).Row
 
    For i = endrow To 4 Step -1
        li = 0
        x = Workbooks("Ж.xlsm").Sheets("К").Cells(i, 2).Value
        With Workbooks("B.xlsm").Sheets("B")
        ReDim avArr(1 To Rows.Count, 1 To 1)
        vCriteria = x
        With New Collection
            On Error Resume Next
            For Each rCell In Range("B2", Cells(Rows.Count, 2).End(xlUp))
                If rCell = vbNullString Or rCell = "" Then Resume Next
                If rCell.Offset(, -1).Value = vCriteria Then
                    .Add rCell.Value, CStr(rCell.Value)
                    If Err = 0 Then
                        li = li + 1: avArr(li, 1) = rCell.Value
                    Else: Err.Clear
                    End If
                End If
            Next
        End With
        End With
        If li Then
            Workbooks("Ж.xlsm").Sheets("К").Rows(i + 1 & ":" & i + li).Insert Shift:=xlDown
            Workbooks("Ж.xlsm").Sheets("К").Cells(i + 1, 2).Resize(li).Value = avArr
        End If
        With Workbooks("Ж.xlsm").Sheets("К")
             For t = i + 1 To i + li
                 v = Cells(t, 2).Value
                If v = "Другие" Then
                   u = Cells(i + li, 2).Value
                   Cells(i + li, 2) = v
                   Cells(t, 2) = u
                   R = i + li - 1
                Else
                   R = i + li
                End If
             Next
        End With
            Workbooks("Ж.xlsm").Worksheets("К").Sort.SortFields.Clear
            Workbooks("Ж.xlsm").Worksheets("К").Sort.SortFields.Add Key:=Range("B:B"), _
                SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            With Workbooks("Ж.xlsm").Worksheets("К").Sort
                .SetRange Range(Cells(i + 1, 2), Cells(R, 2))
                .Header = xlNo
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
        Next
    Workbooks("B.xlsm").Close 0
End Sub


В этом коде вот тут:

Код (vb) Выделить Развернуть

With Workbooks("Ж.xlsm").Sheets("К")
             For t = i + 1 To i + li
                 v = Cells(t, 2).Value
                If v = "Другие" Then
                   u = Cells(i + li, 2).Value
                   Cells(i + li, 2) = v
                   Cells(t, 2) = u
                   R = i + li - 1
                Else
                   R = i + li
                End If
             Next
        End With
почему то не работает with и данные берутся из другой книги. Подскажите почему так.

Все переставил строки все заработало не понятно только что было не так когда они располагались ниже.