Dim wb_source As Workbook Dim wb_result As Workbook Function create_bo

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
Dim wb_source As Workbook
Dim wb_result As Workbook
Function create_book()
Set wb_source = ActiveWorkbook
Set wb_result = Workbooks.Add
End Function
Function deleteSheets()
For i = 2 To wb_result.Sheets.Count
wb_result.Sheets(i).Delete
Next i
End Function
Function sheetEmpty(sheet As Worksheet) As Boolean
If sheet.UsedRange.Rows.Count > 1 Then
sheetEmpty = False
Else
sheetEmpty = True
End If
End Function
Function pr()
Dim a, b As Worksheet
Set a = wb_source.Sheets(2)
Set b = wb_source.Sheets(3)
a.Range("A1:G" & a.UsedRange.Rows.Count).Copy
Dim temp As Integer
Dim res_sh As Worksheet
If sheetEmpty(wb_result.Sheets(wb_result.Sheets.Count)) Then
Set res_sh = wb_result.Sheets(wb_result.Sheets.Count)
Else
Set res_sh = wb_result.Sheets.Add
End If
res_sh.Range("A1").PasteSpecial
res_sh.Range("A1:G" & a.UsedRange.Rows.Count).Columns.AutoFit
For i = 2 To a.UsedRange.Rows.Count
On Error Resume Next
temp = WorksheetFunction.VLookup(Cells(i, 4), b.Range("A2:B" & b.UsedRange.Rows.Count), 2, 0)
On Error GoTo 0
If temp <> 0 Then
If Cells(i, 3) > temp Then
res_sh.Range("A" & i, "G" & i).Interior.ColorIndex = 34
res_sh.Cells(i, 3).Value = temp
End If
End If
temp = 0
Next i
End Function
Function task2()
Dim a, b As Worksheet
Set a = wb_source.Sheets(2)
Set b = wb_source.Sheets(8)
Set namesCom = wb_source.Sheets(1)
Set namesCom1 = wb_result.Sheets.Add
namesCom.Range("A1:B" & namesCom.UsedRange.Rows.Count).Copy Destination:=namesCom1.Range("A1")
temp = ""
Set d = wb_result.Sheets.Add
For i = 2 To a.UsedRange.Rows.Count
On Error Resume Next
temp = WorksheetFunction.VLookup(a.Cells(i, 5).Value, b.Range("A2:A" & b.UsedRange.Rows.Count), 1, 0)
On Error GoTo 0
If temp <> "" Then
namesCom.Range("A1:B" & namesCom.UsedRange.Rows.Count).AutoFilter Field:=1, Criteria1:=a.Cells(i, 1).Value
namesCom.AutoFilter.Range.Copy Destination:=d.Range("A1")
namesCom.Range("A1:B" & namesCom.UsedRange.Rows.Count).AutoFilter Field:=1
check = False
For j = 2 To d.UsedRange.Rows.Count
job = ""
On Error Resume Next
job = WorksheetFunction.VLookup(d.Cells(j, 2).Value, wb_source.Sheets(4).Range("A2:D" & wb_source.Sheets(4).UsedRange.Rows.Count), 4, 0)
job = WorksheetFunction.VLookup(d.Cells(j, 2).Value, wb_source.Sheets(5).Range("A2:L" & wb_source.Sheets(5).UsedRange.Rows.Count), 4, 0)
job = WorksheetFunction.VLookup(d.Cells(j, 2).Value, wb_source.Sheets(6).Range("A2:C" & wb_source.Sheets(6).UsedRange.Rows.Count), 3, 0)
On Error GoTo 0
If InStr(job, "переводчик") <> 0 Then
check = True
Exit For
End If
Next j
d.Cells.Clear
If check = False Then
For j = 2 To wb_source.Sheets(4).UsedRange.Rows.Count
check2 = False
If InStr(wb_source.Sheets(4).Cells(j, 4).Value, "переводчик") <> 0 Then
namesCom.Range("A1:B" & namesCom.UsedRange.Rows.Count).AutoFilter Field:=2, Criteria1:=wb_source.Sheets(4).Cells(j, 1).Value
namesCom.AutoFilter.Range.Copy Destination:=d.Range("A1")
namesCom.Range("A1:B" & namesCom.UsedRange.Rows.Count).AutoFilter Field:=2
num = ""
For k = 2 To d.UsedRange.Rows.Count
num = WorksheetFunction.Match(d.Cells(k, 1).Value, a.Range("A1:A" & a.UsedRange.Rows.Count), 0)
If a.Cells(num, 2).Value + a.Cells(num, 3).Value < a.Cells(i, 2).Value Or a.Cells(i, 2).Value + a.Cells(i, 3).Value < a.Cells(num, 2) Then
namesCom1.Cells(namesCom.UsedRange.Rows.Count + 1, 2) = d.Cells(2, 2).Value
namesCom1.Cells(namesCom.UsedRange.Rows.Count + 1, 1) = a.Cells(i, 1).Value
namesCom1.Range("A" & namesCom.UsedRange.Rows.Count + 1, "B" & namesCom.UsedRange.Rows.Count + 1).Interior.ColorIndex = 34
check2 = True
d.Cells.Clear
Exit For
End If
Next k
End If
If check2 = True Then
Exit For
End If
d.Cells.Clear
Next j
End If
End If
temp = ""
Next i
namesCom1.Range("A2:B" & namesCom1.UsedRange.Rows.Count).Sort key1:=namesCom1.Range("A2"), Order1:=xlAscending
namesCom1.Range("A1:B" & namesCom.UsedRange.Rows.Count).Columns.AutoFit
d.Delete
End Function