Главная страница Случайная страница
Разделы сайта
АвтомобилиАстрономияБиологияГеографияДом и садДругие языкиДругоеИнформатикаИсторияКультураЛитератураЛогикаМатематикаМедицинаМеталлургияМеханикаОбразованиеОхрана трудаПедагогикаПолитикаПравоПсихологияРелигияРиторикаСоциологияСпортСтроительствоТехнологияТуризмФизикаФилософияФинансыХимияЧерчениеЭкологияЭкономикаЭлектроника
Приложения 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
|
|