Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Добавить MsgBox к макросу - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Добавить MsgBox к макросу (Макросы/Sub)
Добавить MsgBox к макросу
akaDemik Дата: Вторник, 01.03.2016, 15:45 | Сообщение № 1
Группа: Пользователи
Ранг: Участник
Сообщений: 67
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Доброго времени суток!
Имеется макрос, к которому необходимо добавить Окно сообщения, в котором будет подсчитано количество пропущенных строк

данный макрос выполняет поиск значения в одной книге и копирование значения в другую книгу, если значение не найдено - переход на следующую строку. Необходимо посчитать сколько и наименование значений пропусков в книге "*_База.xls*", кроме исключения
Код
    Case "", "Книги", "Журналы"

В данном примере должно быть количество: 2, наименования: Космо, Вокруг света
К сообщению приложен файл: 4468823.zip (21.1 Kb)


Сообщение отредактировал akaDemik - Вторник, 01.03.2016, 15:46
 
Ответить
СообщениеДоброго времени суток!
Имеется макрос, к которому необходимо добавить Окно сообщения, в котором будет подсчитано количество пропущенных строк

данный макрос выполняет поиск значения в одной книге и копирование значения в другую книгу, если значение не найдено - переход на следующую строку. Необходимо посчитать сколько и наименование значений пропусков в книге "*_База.xls*", кроме исключения
Код
    Case "", "Книги", "Журналы"

В данном примере должно быть количество: 2, наименования: Космо, Вокруг света

Автор - akaDemik
Дата добавления - 01.03.2016 в 15:45
Manyasha Дата: Вторник, 01.03.2016, 16:35 | Сообщение № 2
Группа: Модераторы
Ранг: Старожил
Сообщений: 2198
Репутация: 898 ±
Замечаний: 0% ±

Excel 2010, 2016
akaDemik, не очень поняла...нужно посчитать кол-во книг, для которых не проставилась цена?
Комментариями пометила то, что добавилось
[vba]
Код
Sub Obrabotka_Periodiki()
    Dim i&, j&, LastRow&, MyPath$, MyFileName$, MyFullName$, A, Dic As Object
    Dim kol1&, kol2& 'Добавила 2 переменные
    Dim Wb_Ish As Workbook, Wb_Target As Workbook, Sh_Ish As Worksheet, Sh_Target As Worksheet
      MyPath = ActiveWorkbook.Path & "\"
    Set Wb_Target = ActiveWorkbook
    Set Sh_Target = Wb_Target.Worksheets("Периодика")
    Set Dic = CreateObject("Scripting.Dictionary"): Dic.CompareMode = 1
    Application.ScreenUpdating = False
    With Sh_Target
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        A = .Range("A1:A" & LastRow).Value
        For i = 1 To UBound(A, 1)
            A(i, 1) = Trim(A(i, 1))
            Select Case A(i, 1)
                Case "", "Книги", "Журналы"
                Case Else
                     Dic(A(i, 1)) = i: kol1 = kol1 + 1 'Общее количество
            End Select
        Next i
        MyFileName = Dir(MyPath & "*_База.xls*")
        Do Until MyFileName = ""
            MyFullName = MyPath & MyFileName
            Set Wb_Ish = Workbooks.Open(Filename:=MyFullName, UpdateLinks:=0, ReadOnly:=True)
            Set Sh_Ish = Wb_Ish.Worksheets("TDSheet")
                With Sh_Ish
                    LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
                    A = .Range("A1:D" & LastRow).Value
                End With
                For i = 1 To LastRow
                    A(i, 1) = Trim(A(i, 1))
                    If A(i, 1) <> "" Then
                        If Dic.Exists(A(i, 1)) Then
                            With .Range("D" & Dic(A(i, 1)))
                    .Value = A(i, 4)
                    .Font.Color = vbRed
                    kol2 = kol2 + 1 'количество найденных в "*_База.xls*"
                            End With
                        End If
                    End If
                Next i
            Wb_Ish.Close SaveChanges:=False
            MyFileName = Dir
        Loop
        MsgBox kol1 - kol2 'Вывод сообщения
    End With
    Set Dic = Nothing: Set Wb_Ish = Nothing: Set Wb_Target = Nothing:  Set Sh_Ish = Nothing: Set Sh_Target = Nothing
End Sub
[/vba]


ЯД: 410013299366744 WM: R193491431804
 
Ответить
СообщениеakaDemik, не очень поняла...нужно посчитать кол-во книг, для которых не проставилась цена?
Комментариями пометила то, что добавилось
[vba]
Код
Sub Obrabotka_Periodiki()
    Dim i&, j&, LastRow&, MyPath$, MyFileName$, MyFullName$, A, Dic As Object
    Dim kol1&, kol2& 'Добавила 2 переменные
    Dim Wb_Ish As Workbook, Wb_Target As Workbook, Sh_Ish As Worksheet, Sh_Target As Worksheet
      MyPath = ActiveWorkbook.Path & "\"
    Set Wb_Target = ActiveWorkbook
    Set Sh_Target = Wb_Target.Worksheets("Периодика")
    Set Dic = CreateObject("Scripting.Dictionary"): Dic.CompareMode = 1
    Application.ScreenUpdating = False
    With Sh_Target
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        A = .Range("A1:A" & LastRow).Value
        For i = 1 To UBound(A, 1)
            A(i, 1) = Trim(A(i, 1))
            Select Case A(i, 1)
                Case "", "Книги", "Журналы"
                Case Else
                     Dic(A(i, 1)) = i: kol1 = kol1 + 1 'Общее количество
            End Select
        Next i
        MyFileName = Dir(MyPath & "*_База.xls*")
        Do Until MyFileName = ""
            MyFullName = MyPath & MyFileName
            Set Wb_Ish = Workbooks.Open(Filename:=MyFullName, UpdateLinks:=0, ReadOnly:=True)
            Set Sh_Ish = Wb_Ish.Worksheets("TDSheet")
                With Sh_Ish
                    LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
                    A = .Range("A1:D" & LastRow).Value
                End With
                For i = 1 To LastRow
                    A(i, 1) = Trim(A(i, 1))
                    If A(i, 1) <> "" Then
                        If Dic.Exists(A(i, 1)) Then
                            With .Range("D" & Dic(A(i, 1)))
                    .Value = A(i, 4)
                    .Font.Color = vbRed
                    kol2 = kol2 + 1 'количество найденных в "*_База.xls*"
                            End With
                        End If
                    End If
                Next i
            Wb_Ish.Close SaveChanges:=False
            MyFileName = Dir
        Loop
        MsgBox kol1 - kol2 'Вывод сообщения
    End With
    Set Dic = Nothing: Set Wb_Ish = Nothing: Set Wb_Target = Nothing:  Set Sh_Ish = Nothing: Set Sh_Target = Nothing
End Sub
[/vba]

Автор - Manyasha
Дата добавления - 01.03.2016 в 16:35
akaDemik Дата: Вторник, 01.03.2016, 18:14 | Сообщение № 3
Группа: Пользователи
Ранг: Участник
Сообщений: 67
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
нужно посчитать кол-во книг, для которых не проставилась цена?

да, нужно количество и наименование книг
проверил макрос, как-то неправильно считает

как я выше писал, должно быть 2 наименования Космо, Вокруг света
 
Ответить
Сообщение
нужно посчитать кол-во книг, для которых не проставилась цена?

да, нужно количество и наименование книг
проверил макрос, как-то неправильно считает

как я выше писал, должно быть 2 наименования Космо, Вокруг света

Автор - akaDemik
Дата добавления - 01.03.2016 в 18:14
Manyasha Дата: Вторник, 01.03.2016, 19:00 | Сообщение № 4
Группа: Модераторы
Ранг: Старожил
Сообщений: 2198
Репутация: 898 ±
Замечаний: 0% ±

Excel 2010, 2016
akaDemik, поняла, и наверное только уникальные значения нужны. Проверяйте:
К сообщению приложен файл: -1.xlsm (21.5 Kb)


ЯД: 410013299366744 WM: R193491431804
 
Ответить
СообщениеakaDemik, поняла, и наверное только уникальные значения нужны. Проверяйте:

Автор - Manyasha
Дата добавления - 01.03.2016 в 19:00
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Добавить MsgBox к макросу (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!