Приложения 7

Тексты программных модулей

1 Модуль pack

Sub packs()

Dim a(9999), b(9999), bb(9999)

Range(Cells(2, 4), Cells(9999, 5)).Select

Selection.Clear

i = 2

Cells(i, 1).Select

q = Selection

Do While q < > " "

a(i - 1) = q

Cells(i + 1, 1).Select

q = Selection

i = i + 1

Loop

i = 1

Cells(i + 1, 2).Select

q = Selection

Do While q < > " "

b(i) = q

k = 0

For ii = 1 To 9999

kk = 0

bb(i - 1) = 2

If b(i - 1) = " " Then Exit For

If b(i - 1) = b(ii) And kk = 0 And k = 0 Then k = 1: kk = 2

If b(i - 1) = b(ii) And k = 1 And kk = 0 Then bb(i - 1) = 1: Exit For

Next

Cells(i + 2, 2).Select

q = Selection

i = i + 1

Loop

ii = 2

i = 1

For i = 1 To 9999

If a(i) = " " Then Exit For

Do While a(i) < > " -"

Cells(ii, 3).Select

ii = ii + 1

Selection = a(i)

Exit Do

Loop

For iii = i + 1 To 9999

If a(iii) = " " Then Exit For

If a(i) = a(iii) Then a(iii) = " -"

Next

Next

i = 2

Cells(i, 1).Select

q = Selection

Do While q < > " "

a(i - 1) = q

Cells(i + 1, 1).Select

q = Selection

i = i + 1

Loop

i = 2

Cells(i, 3).Select

q = Selection

Do While q < > " "

For ii = 1 To 9999

Do While a(ii) = q

If a(ii) = q And bb(ii) = 1 Then Cells(i, 4).Select

If a(ii) = q And bb(ii) = 2 Then Cells(i, 5).Select

If a(ii) = " " Then Exit For

Selection = 1 + Selection

Exit Do

Loop

If a(ii) = " " Then Exit For

Next

Cells(i + 1, 3).Select

q = Selection

i = i + 1

Loop

End Sub

Вызыв

Sub pack()

Dim oXL As Object

Set oXL = CreateObject(" Excel.Application")

With oXL

.Workbooks.Open " C: \2\упаковка.xlsm"

.Visible = True

End With

Set oXL = Nothing

End Sub

Приложения 8

2. Макрос avto

Sub packs()

Dim a(9999), b(9999), bb(9999)

Range(Cells(2, 4), Cells(9999, 5)).Select

Selection.Clear

i = 2

Cells(i, 1).Select

q = Selection

Do While q < > " "

a(i - 1) = q

Cells(i + 1, 1).Select

q = Selection

i = i + 1

Loop

i = 1

Cells(i + 1, 2).Select

q = Selection

Do While q < > " "

b(i) = q

k = 0

For ii = 1 To 9999

kk = 0

bb(i - 1) = 2

If b(i - 1) = " " Then Exit For

If b(i - 1) = b(ii) And kk = 0 And k = 0 Then k = 1: kk = 2

If b(i - 1) = b(ii) And k = 1 And kk = 0 Then bb(i - 1) = 1: Exit For

Next

Cells(i + 2, 2).Select

q = Selection

i = i + 1

Loop

ii = 2

i = 1

For i = 1 To 9999

If a(i) = " " Then Exit For

Do While a(i) < > " -"

Cells(ii, 3).Select

ii = ii + 1

Selection = a(i)

Exit Do

Loop

For iii = i + 1 To 9999

If a(iii) = " " Then Exit For

If a(i) = a(iii) Then a(iii) = " -"

Next

Next

i = 2

Cells(i, 1).Select

q = Selection

Do While q < > " "

a(i - 1) = q

Cells(i + 1, 1).Select

q = Selection

i = i + 1

Loop

i = 2

Cells(i, 3).Select

q = Selection

Do While q < > " "

For ii = 1 To 9999

Do While a(ii) = q

If a(ii) = q And bb(ii) = 1 Then Cells(i, 4).Select

If a(ii) = q And bb(ii) = 2 Then Cells(i, 5).Select

If a(ii) = " " Then Exit For

Selection = 1 + Selection

Exit Do

Loop

If a(ii) = " " Then Exit For

Next

Cells(i + 1, 3).Select

q = Selection

i = i + 1

Loop

End Sub

Вызыв:

Sub avto()

Dim oXL As Object

Set oXL = CreateObject(" Excel.Application")

With oXL

.Workbooks.Open " C: \2\авто.xlsm"

.Visible = True

End With

Set oXL = Nothing

End Sub