Доброго времени суток! Имеется макрос, к которому необходимо добавить Окно сообщения, в котором будет подсчитано количество пропущенных строк
[vba]
Код
Sub Obrabotka_Periodiki() Dim i&, j&, LastRow&, MyPath$, MyFileName$, MyFullName$, A, Dic As Object 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 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 End With End If End If Next i Wb_Ish.Close SaveChanges:=False MyFileName = Dir Loop End With Set Dic = Nothing: Set Wb_Ish = Nothing: Set Wb_Target = Nothing: Set Sh_Ish = Nothing: Set Sh_Target = Nothing End Sub
[/vba]
данный макрос выполняет поиск значения в одной книге и копирование значения в другую книгу, если значение не найдено - переход на следующую строку. Необходимо посчитать сколько и наименование значений пропусков в книге "*_База.xls*", кроме исключения
Код
Case "", "Книги", "Журналы"
В данном примере должно быть количество: 2, наименования: Космо, Вокруг света
Доброго времени суток! Имеется макрос, к которому необходимо добавить Окно сообщения, в котором будет подсчитано количество пропущенных строк
[vba]
Код
Sub Obrabotka_Periodiki() Dim i&, j&, LastRow&, MyPath$, MyFileName$, MyFullName$, A, Dic As Object 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 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 End With End If End If Next i Wb_Ish.Close SaveChanges:=False MyFileName = Dir Loop End With Set Dic = Nothing: Set Wb_Ish = Nothing: Set Wb_Target = Nothing: Set Sh_Ish = Nothing: Set Sh_Target = Nothing End Sub
[/vba]
данный макрос выполняет поиск значения в одной книге и копирование значения в другую книгу, если значение не найдено - переход на следующую строку. Необходимо посчитать сколько и наименование значений пропусков в книге "*_База.xls*", кроме исключения
Код
Case "", "Книги", "Журналы"
В данном примере должно быть количество: 2, наименования: Космо, Вокруг светаakaDemik
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]
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
akaDemik, поняла, и наверное только уникальные значения нужны. Проверяйте:
[vba]
Код
Sub Obrabotka_Periodiki() Dim i&, j&, LastRow&, MyPath$, MyFileName$, MyFullName$, A, Dic As Object, Dic2 As Object 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 'Если нужны уникальные Set Dic2 = 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 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 End With ElseIf A(i, 1) <> "Книги" And A(i, 1) <> "Журналы" Then 'Если нужны уникальные If Not Dic2.exists(A(i, 1)) Then Dic2(A(i, 1)) = i: s = s & ", " & A(i, 1) 'Если нужны все ' kol = kol + 1: s = s & ", " & A(i, 1) End If End If Next i Wb_Ish.Close SaveChanges:=False MyFileName = Dir Loop s = Mid(s, 3) 'Если нужны уникальные MsgBox Dic2.Count & " наименования: " & s 'Если нужны все ' MsgBox kol & " наименования: " & s End With Set Dic = Nothing: Set Wb_Ish = Nothing: Set Wb_Target = Nothing: Set Sh_Ish = Nothing: Set Sh_Target = Nothing End Sub
[/vba]
akaDemik, поняла, и наверное только уникальные значения нужны. Проверяйте:
[vba]
Код
Sub Obrabotka_Periodiki() Dim i&, j&, LastRow&, MyPath$, MyFileName$, MyFullName$, A, Dic As Object, Dic2 As Object 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 'Если нужны уникальные Set Dic2 = 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 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 End With ElseIf A(i, 1) <> "Книги" And A(i, 1) <> "Журналы" Then 'Если нужны уникальные If Not Dic2.exists(A(i, 1)) Then Dic2(A(i, 1)) = i: s = s & ", " & A(i, 1) 'Если нужны все ' kol = kol + 1: s = s & ", " & A(i, 1) End If End If Next i Wb_Ish.Close SaveChanges:=False MyFileName = Dir Loop s = Mid(s, 3) 'Если нужны уникальные MsgBox Dic2.Count & " наименования: " & s 'Если нужны все ' MsgBox kol & " наименования: " & s End With Set Dic = Nothing: Set Wb_Ish = Nothing: Set Wb_Target = Nothing: Set Sh_Ish = Nothing: Set Sh_Target = Nothing End Sub