Option Explicit
' Макрос для розрахунку даних (збігу основних показників) _
та розфарбування таблиці з проблемними місцями (при чому: проблемні _
місця переносяться на інший лист з кольором (що дає можливість краще _
оцінювати ситуацію з проблемними даними.
Sub Count_And_Print()
Dim LastRow As Long
Dim LastRowUP As Long
Dim CambRow As Integer
Dim Agent As Areas
Dim Docum As Areas
Dim Date1 As Areas
Dim Summ As Areas
Dim LastRow2 As Long
Dim LastRowUP2 As Long
Dim LastRowDiff As Long
Dim FIOLastRow As Long
Dim FIOLastRow2 As Long
Application.ScreenUpdating = False
Sheets("Злитий").Activate
LastRow = Range("A65000").End(xlUp).Row
LastRow2 = Range("N65000").End(xlUp).Row
Cells(1, 7) = "Заг. Сумма"
Cells(1, 8) = "ФІО"
Cells(1, 9) = "Ном.Догов."
Cells(1, 10) = "ФІО/№"
Cells(1, 11) = "/+сумма"
Cells(1, 12) = "/+дата"
Cells(1, 13) = "№/Сумм"
ActiveWorkbook.Names.Add Name:="Date1", RefersTo:=Range(Cells(2, 14), Cells(LastRow2, 14))
ActiveWorkbook.Names.Add Name:="Agent", RefersTo:=Range(Cells(2, 15), Cells(LastRow2, 15))
ActiveWorkbook.Names.Add Name:="Docum", RefersTo:=Range(Cells(2, 16), Cells(LastRow2, 16))
ActiveWorkbook.Names.Add Name:="Summ", RefersTo:=Range(Cells(2, 17), Cells(LastRow2, 17))
Range("Date1").Select
Selection.NumberFormat = "0.00"
'Необхідно суттєві доопрацювання!!!
For CambRow = 2 To LastRow
Cells(CambRow, 3) = WorksheetFunction.Trim(Cells(CambRow, 3)) ' чистка зайвих пробілів в фаміліях
Cells(CambRow, 7) = WorksheetFunction.Sum(Range(Cells(CambRow, 4), Cells(CambRow, 6))) ' при підрахуванні суми деякі значення з _
даних менеджерів ідуть як текст як змінити це в Excel??? які можна застосувати функції??
Cells(CambRow, 8) = WorksheetFunction.CountIf(Range("Agent"), Cells(CambRow, 3))
Cells(CambRow, 9) = WorksheetFunction.CountIf(Range("Docum"), Cells(CambRow, 1))
Cells(CambRow, 10) = WorksheetFunction.CountIfs(Range("Agent"), Cells(CambRow, 3), Range("Docum"), Cells(CambRow, 1))
Cells(CambRow, 11) = WorksheetFunction.CountIfs(Range("Agent"), Cells(CambRow, 3), Range("Docum"), Cells(CambRow, 1), _
Range("Summ"), Cells(CambRow, 7))
Cells(CambRow, 12) = WorksheetFunction.CountIfs(Range("Agent"), Cells(CambRow, 3), Range("Docum"), Cells(CambRow, 1), _
Range("Summ"), Cells(CambRow, 7), Range("Date1"), Cells(CambRow, 2))
Cells(CambRow, 13) = WorksheetFunction.CountIfs(Range("Docum"), Cells(CambRow, 1), Range("Summ"), Cells(CambRow, 7))
' на даний момент не працює необхідно вирішити _
як можна автоматично змінити дату з вигрузки 1С (як застосувати формулу дата Знач)??
Next CambRow
'===============================================================================================================================
' необхідно зробити відбір по значенням (тобто якщо ідуть повтори/або відсутні (значення відмінне від 1)
' фарбуваня кольором відповідних значень
' переніс проблемних рядків на окремий лист (з кольором проблемних даних) та поряд з даними 1С
' Різниця значень у понад 1 одиницю??? (що робити)
For CambRow = 2 To LastRow
If Cells(CambRow, 12) = 0 Then
Range(Cells(CambRow, 1), Cells(CambRow, 7)).Select
Selection.Interior.Color = 35535
End If
If Cells(CambRow, 11) = 0 And Cells(CambRow, 8) <> 0 Then
Range(Cells(CambRow, 4), Cells(CambRow, 7)).Select
Selection.Interior.Color = 65535
End If
If Cells(CambRow, 11) > Cells(CambRow, 12) Then
Cells(CambRow, 2).Select
Selection.Interior.Color = 65535
End If
If Cells(CambRow, 8) = 0 And Cells(CambRow, 9) = 0 And Cells(CambRow, 10) = 0 And _
Cells(CambRow, 11) = 0 And Cells(CambRow, 12) = 0 And Cells(CambRow, 13) = 0 Then
Range(Cells(CambRow, 1), Cells(CambRow, 7)).Select
Selection.Interior.Color = 5535
End If
If Cells(CambRow, 8) <> Cells(CambRow, 9) Then
If Cells(CambRow, 8) > Cells(CambRow, 9) Then
Cells(CambRow, 1).Select
Selection.Interior.Color = 65535
ElseIf Cells(CambRow, 8) < Cells(CambRow, 9) Then
Cells(CambRow, 3).Select
Selection.Interior.Color = 65535
End If
End If
Next CambRow
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Перенесення даних з листа "Злитий" в лист "Розбіжності" (для відображення обєктивної картини)
Sheets("Злитий").Activate
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Доп свод данных для исчесления общей суммы и соответственной раскарски данных...
FIOLastRow = Cells(65000, 15).End(xlUp).Row
'ActiveWorkbook.Names.Add Name:="Agent", RefersTo:=Range(Cells(2, 15), Cells(FIOLastRow, 15))
Range("Agent").Select
Selection.Copy
Cells(2, 19).Select
ActiveSheet.Paste
FIOLastRow2 = Cells(65000, 19).End(xlUp).Row
ActiveWorkbook.Names.Add Name:="Agent2", RefersTo:=Range(Cells(2, 19), Cells(FIOLastRow, 19))
' ActiveWorkbook.Names.Add Name:="Summ", RefersTo:=Range(Cells(2, 17), Cells(FIOLastRow, 17))
ActiveSheet.Range("Agent2").RemoveDuplicates Columns:=1, Header:=xlNo ' '' Не понимаю???
FIOLastRow2 = Cells(65000, 19).End(xlUp).Row
For CambRow = 2 To FIOLastRow2 ' 438
'Cells(CambRow, 20) = WorksheetFunction.SummIf(Range(Cells(2, 15), Cells(FIOLastRow, 17)), Cells(CambRow, 19), Range("Summ")) ' сейчас не могу сделать подсчет...
Next CambRow
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sheets("Злитий").Activate
LastRow = Range("A65000").End(xlUp).Row
Sheets("Розбіжності").Activate
Cells(11, 1) = "№ дог"
Cells(11, 2) = "Дата"
Cells(11, 3) = "Ф.И.О. клиента"
Cells(11, 4) = "Заг. Сумма"
'''''' Перенесення виділених даних ' зараз працює правильно!!!
'Перенос выделенных данных, сейчас работает правильно!... но выше выведенная формула по _
столбцу 12 выбивает везде 0... (отредактировать формулу)!
For CambRow = 2 To LastRow
Sheets("Злитий").Activate
If Cells(CambRow, 12) = 0 Then
Range(Cells(CambRow, 1), Cells(CambRow, 3)).Select
Selection.Copy
Sheets("Розбіжності").Activate
LastRowDiff = Range("A65000").End(xlUp).Row ' Визначаю останній заповнений рядок
Sheets("Розбіжності").Cells(LastRowDiff + 1, 1).Select
ActiveSheet.Paste
Sheets("Злитий").Activate
Cells(CambRow, 7).Select
Selection.Copy
Sheets("Розбіжності").Activate
Sheets("Розбіжності").Cells(LastRowDiff + 1, 4).Select
ActiveSheet.Paste
End If
Next CambRow
Sheets("Розбіжності").Activate
Range("B11").Select
Selection.AutoFilter
Cells.Select
Cells.EntireColumn.AutoFit
Cells.EntireRow.AutoFit
Application.ScreenUpdating = True
MsgBox "Перенесення даних завершено"
End Sub
|
