Темы

Здравствуйте. Такой вот вопрос есть два модуля почти одинаковые в одном модуле(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

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

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

Код (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 и данные берутся из другой книги. Подскажите почему так.

Тут получается массив с уникальными значениями и потом вставляется на лист. Там все это дело в цикле и он должен несколько раз собрать этот массив для разных значений. Но он собирает его один раз вставляет и все дальше он максимум один раз вставляет пустые строки или вообще ничего не делает.

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

Sub nap()

Workbooks.Open ("D:\Desktop\ж\b.xlsm")
Windows("b").Activate

    Dim rCell As Range, avArr, li As Long, vCriteria
    ReDim avArr(1 To Rows.Count, 1 To 1)
   
    Windows("Ж").Activate
    endrow = Workbooks("Ж.xlsm").Sheets("К").Cells(4, 2).End(xlDown).Row

    For i = 4 To endrow
    x = Cells(i, 2).Value
    Windows("b").Activate
   
    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
    If li Then
    Windows("Ж").Activate
    Rows(i + 1 & ":" & i + li).Select
    Selection.Insert Shift:=xlDown
    Cells(i + 1, 2).Resize(li).Value = avArr
    End If
    Erase avArr
    i = i + li
    Next

Workbooks("b.xlsm").Close


End Sub

Подскажите что не так ? где там ошибка ?

Здравствуйте. Прошу помочь с такой ерундой. Есть лист эксель со столбцом заполненным разными записями и есть массив из одного столбца тоже. Задача в том что бы добавить значения из массива в имеющийся столбец на листе.
Если сделать так:

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

Cells(i + 1, 2).Resize(li).Value = avArr
то значения просто вставляются и затирают те данные которые уже есть в столбце. Есть ли подобное простое решение в одну-две строки кода ? Или надо вычислять количество элементов в массиве, добавлять то же количество строк и потом вставлять туда данные из массива ?

Здравствуйте. Нужна помощь с макросом. Есть таблица в ней в 13(M) столбце стоят числа надо пройтись по всей таблице скопировать строки и вставить ниже под текущей такое количество раз как число в 13 столбце текущей строки и что бы во всех вставленных строках и текущей в итоге в 13 столбце стало число 1.  Я попробовал написать макрос но так как в них не силен заблудился и застрял.
Получилась такая ерунда:

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

Sub azaz()

EndRow = ThisWorkbook.Sheets("Base").Cells(2, 1).End(xlDown).Row

f = 1

For x = 2 To EndRow
  p1 = Cells(x, 13).Value
  If Cells(x, 13) > 1 Then
   c = p1 - 1
    Row.Select
    Selection.Copy
    Selection.Insert Shift:=xlDown
    d = x + 1
    For Each cell In Range(Cells(d, 13), Cells(x, 13))
    Cells.Value = c
    Next cell
2:
    End If
     Cells(x, 13).Select
     If c > 1 Then GoTo 1
      Next x
     
1:
   c = Cells(x, 13).Value - 1
    Row.Select
    Selection.Copy
    Selection.Insert Shift:=xlDown
    d = x + 1 + f
    For Each cell In Range(Cells(d, 13), Cells(x, 13))
    Cells.Value = c
    Next cell
    f = f + 1
    GoTo 2
   
End Sub

Похоже оно не жизнеспособно. Выдает ошибку и выделяет желтым строку Row.Select

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

Извиняюсь нормальное название придумать не смог для темы. Если кто лучше придумает переименуйте пожалуйста.
Вот такой вопрос можно ли сделать что бы несколько пользователей одновременно  получали нужные данные из одной закрытой книги а после завершения работы нужные значения сохранялись в эту закрытую книгу ?
Похоже и с формулировкой вопроса у меня проблемы  :D Надеюсь более менее понятно написал.

Такая ерунда делаю лист бокс на 3 столбца устанавливаю размеры. Дальше при изменении любых параметров в свойствах он уменьшается в размере. Меняешь еще что нибудь и он еще раз уменьшается и так до бесконечности. Так же после заполнения данными он уменьшается. Не понимаю что это такое  глюк какой то или это  нормальное явление или что то не так сделал ?

Ответ на такой вопрос найти не вышло спрошу тут. Не знаю при сортировке перемещаются значения или ячейки полностью. В общем 2 столбца в таблице значения в первом сортируются по алфавиту. Можно ли сделать что бы значения из 2 столбца перемещались вместе со значениями в первом ?
Например в первом столбце написано "Ананасы" а во втором рядом "Большой ананас" после сортировки "Ананасы" перемещаются в начало таблицы а "Большой ананас" остается на месте. А надо что бы "Большой ананас" перемещалось вместе с "Ананасы".

Искал искал и ничего на эту тему не нашел поэтому спрашиваю тут. Может ли эксель переводить множественное число в единственное ? Есть список 2 столбца в первом записаны предметы во множественном числе можно ли сделать что бы автоматом во втором столбце они писались в единственном.
Например:
"Ананасы"  "Ананас"
"Большие хреновины" "Большая хреновина"

Имеется ComboBox под названием StrokaPoiska. Написал для него поиск. Заполнил его через StrokaPoiska.AddItem но выходит куча строк и для каждой строки надо вписывать строку в макрос. Покопался на форуме и в интернете вроде как можно заполнить из списка. Есть список но вот реализовать его прикрутку к ComboBox у меня не выходит.

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

Private Sub StrokaPoiska_Click()

Application.EnableEvents = False
Application.DisplayStatusBar = False
Application.DisplayAlerts = False
Application.ScreenUpdating = False
                       
Workbooks.Open ("D:\Desktop\Список.xlsm")
EndRow = Workbooks("Список.xlsm").Sheets("Список").Cells(1, 2).End(xlDown).Row
e = 0

For q = 1 To EndRow
If StrokaPoiska.ListIndex = e Then
   Namet = Workbooks("Список.xlsm").Sheets("Список").Cells(q, 2).Value
   Windows("Таблица 1").Activate    
   Columns(2).Find(What:=Namet, LookIn:= _
       xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
       xlNext, MatchCase:=False, SearchFormat:=False).EntireRow.Select
       e = e + 1
End If
Next q

Workbooks("Список.xlsm").Close

Application.EnableEvents = True
Application.DisplayStatusBar = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Это первый вариант получившийся. Создал в списке Динамический именованный диапазон Spisok. И нифига не вышло  :D

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

Private Sub StrokaPoiska_DropButtonClick()

StrokaPoiska.Clear
Workbooks.Open ("D:\Desktop\Список.xlsm")

StrokaPoiska.List = Spisok

А это еще нашел пример но недопонял как он работает и в итоге тоже вышла фигня вместо макроса  :D

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

Workbooks.Open ("D:\Desktop\Список.xlsm")
EndRow = Workbooks("Список.xlsm").Sheets("Список").Cells(1, 2).End(xlDown).Row

For Each cell In Range(Cells(1, 2), Cells(EndRow, 3)).Cells
   StrokaPoiska.AddItem cell
Next
   StrokaPoiska.ListRows = Range(Cells(1, 2), Cells(EndRow, 3)).Cells.Count
   StrokaPoiska.Value = ActiveCell.Value

End Sub

Как обычно прошу помочь и подсказать насколько все плохо.

Может не так ищу но нигде ничего не могу на эту тему найти. Есть список 1 столбец и надо в соседний столбец вывести первую букву первого слова или цифры.
Например:
"Абрикос"       "А"
"Хрень 1"        "Х"
"1 Хрень"        "1"
"Тут надпись"  "Т"

Как то вообще нет никаких идей может чего подскажете.

Имеется таблица часть строк залита желтым цветом часть другими цветами часть без заливки. Нужно что бы на желтых строках в первом столбце выставлялись номера по порядку 1, 2, 3, и так до конца таблицы автоматически при открытии книги. Написал фигню которая ниже.

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


Private Sub Workbook_Open() 
 
Sheets("Таблица 1").Activate 
Cells(4, 1).Activate 
 
EndRow = Workbooks("Таблица 1.xlsm").Sheets("Таблица 1").Cells(4, 2).End(xlDown).Row 
ColorCell = RGB(225, 225, 0) 
Num = 1 
 
For c = 4 To EndRow 
  If Cells(c, 1).Interior.Color = ColorCell Then 
  Cells(c, 1).Value = Num 
  End If 
Num = Num + 1 
Next c 
 
End Sub 

Как мне кажется оно должно работать  :D Но оно не работает эффекта вообще никакого нет. Подскажите что не так.

Здравствуйте люди добрые.  :D Программированием никогда не занимался. С  экселем вобщем то тоже не особо дружу.
Есть таблица 5  столбцов и куча строк количество строк меняется может становиться больше может меньше. Необходимо сделать такую штуку в 5 столбце выставляются числа и из тех строк где стоят числа после нажатия на кнопку должны перемещаться выборочно некоторые ячейки в другой документ а без цифр просто пропускаться причем список этот в некоторых местах разделяется общими названиями (например хрень 1 и дальше список хрени, хрень2 и дальше список хрени) и в другом документе есть строки хрень1, хрень2 и ячейки из первого документа должны соответственно вписываться справа от соответствующего названия в определенные ячейки.  
Порывшись в интернете смог изобразить такую фигню:

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

Sub Primer1()
For x = 11 to 100000  
  If Cells(x, 16).Value <> vbNullString Then
   Cells(x, 23).Value = Cells(x, 1).Value
   Cells(x, 24).Value = Cells(x, 3).Value
   Cells(x, 25).Value = Cells(x, 4).Value
   Cells(x, 26).Value = Cells(x, 5).Value
   Cells(x, 27).Value = Cells(x, 8).Value
   Cells(x, 28).Value = Cells(x, 16).Value
   Cells(x, 16).Value = vbNullString
  End If
Next x
End Sub
Вобщем не очень выходит как перенести в другую книгу незнаю да и хотелось бы что бы не 100000 ячеек проверялось а только до конца таблицы и как сделать перено определенных позицый в определенные места тоже непонятно.