Форум » Программистские штучки » Сравнение списков VBA » Ответить
Сравнение списков VBA
Бутеноп: [pre2] Sub sravncell() 'Прога для сравнения двух массивов ячеек на листе "Лист2" 'Плюшка пока не дописана, но to be continued! Dim Ok(10000, 1) As String 'Массив, в котором хранятся имена(0) и адреса(1), совпадающие в обоих массивах Dim BE1(10000, 1) As String '->>-, которые есть только в первом массиве Dim BE2(10000, 1) As String '->>-, которые есть только во втором массиве Dim indOk As Integer 'Отсель, индексы соответствующих массивов... Dim indBE1 As Integer Dim indBE2 As Integer '...вот до сель Dim aDr1 As Integer 'Номера первой... Dim aDr2 As Integer 'и второй строки, соответственно Dim CHsize1 As String 'Размеры(по ширине)... Dim CHsize2 As String '...сортируемых массивов Dim kui As Integer 'Счётчик Dim Ksize1 As String 'Размеры(количество строк)... Dim Ksize2 As String '...сортируемых массивов CHsize1 = "a1:b1" CHsize2 = "d1:e1" '''''''''''''''''''''''''''''''''''Дыва''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Columns(Left(CHsize2, 1) & ":" & Mid(CHsize2, 4, 1)).Select ActiveWorkbook.Worksheets("Лист2").Sort.SortFields.Clear ActiveWorkbook.Worksheets("Лист2").Sort.SortFields.Add Key:=Columns(Left(CHsize2, 1)), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("Лист2").Sort .SetRange Range(Left(CHsize2, 1) & ":" & Mid(CHsize2, 4, 1)) .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Range(Left(CHsize2, 2)).Select Ksize2 = 0 Do While ActiveCell.Offset(Ksize2 + 1, 0) <> "" Ksize2 = Ksize2 + 1 Loop ''''''''''''''''''''''''''''''''''''''''''''''''Енд два'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''''''''''''Адын'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Columns(Left(CHsize1, 1) & ":" & Mid(CHsize1, 4, 1)).Select 'Сортировка с счёт количества записей по первому массиву ActiveWorkbook.Worksheets("Лист2").Sort.SortFields.Clear ActiveWorkbook.Worksheets("Лист2").Sort.SortFields.Add Key:=Columns(Left(CHsize1, 1)), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("Лист2").Sort .SetRange Range(Left(CHsize1, 1) & ":" & Mid(CHsize1, 4, 1)) .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Range(Left(CHsize1, 2)).Select Ksize1 = 0 Do While ActiveCell.Offset(Ksize1 + 1, 0) <> "" Ksize1 = Ksize1 + 1 Loop 'Вот до этого места ''''''''''''''''''''''''''''''''''''Енд адын'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|Сравнение_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+|_+| indOk = -1 indBE1 = -1 indBE2 = -1 aDr1 = -1 aDr2 = 0 Do While aDr1 < Ksize1 aDr1 = aDr1 + 1 If ActiveCell.Offset(aDr1, 0) = ActiveCell.Offset(aDr2, 0).Range(Left(CHsize2, 2)) Then indOk = indOk + 1 Ok(indOk, 0) = ActiveCell.Offset(aDr1, 0) Ok(indOk, 1) = aDr1 If aDr2 < Ksize2 Then aDr2 = aDr2 + 1 ElseIf ActiveCell.Offset(aDr1, 0) < ActiveCell.Offset(aDr2, 0).Range(Left(CHsize2, 2)) Then indBE1 = indBE1 + 1 BE1(indBE1, 0) = ActiveCell.Offset(aDr1, 0) BE1(indBE1, 1) = aDr1 ElseIf ActiveCell.Offset(aDr1, 0) > ActiveCell.Offset(aDr2, 0).Range(Left(CHsize2, 2)) And aDr2 < Ksize2 Then indBE2 = indBE2 + 1 BE2(indBE2, 0) = ActiveCell.Offset(aDr2, 0).Range(Left(CHsize2, 2)) BE2(indBE2, 1) = aDr2 If ActiveCell.Offset(aDr1, 0) >= ActiveCell.Offset(aDr2, 0).Range(Left(CHsize2, 2)) Then aDr1 = aDr1 - 1 If aDr2 < Ksize2 Then aDr2 = aDr2 + 1 Else indBE1 = indBE1 + 1 BE1(indBE1, 0) = ActiveCell.Offset(aDr1, 0) BE1(indBE1, 1) = aDr1 End If Loop Do While aDr2 <= Ksize2 indBE2 = indBE2 + 1 BE2(indBE2, 0) = ActiveCell.Offset(aDr2, 0).Range(Left(CHsize2, 2)) BE2(indBE2, 1) = aDr2 aDr2 = aDr2 + 1 Loop ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Конец сравнения''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Application.ScreenUpdating = False For kui = 0 To indOk ActiveCell.Offset(Ok(kui, 1), 0).Range(CHsize1).Copy ActiveCell.Offset(kui, 10).Range(CHsize1).Select ActiveSheet.Paste Range(Left(CHsize1, 2)).Select Next kui For kui = 0 To indBE1 ActiveCell.Offset(BE1(kui, 1), 0).Range(CHsize1).Copy ActiveCell.Offset(kui, 20).Range(CHsize1).Select ActiveSheet.Paste Range(Left(CHsize1, 2)).Select Next kui For kui = 0 To indBE2 ActiveCell.Offset(BE2(kui, 1), 0).Range(CHsize2).Copy ActiveCell.Offset(kui, 20).Range(CHsize2).Select ActiveSheet.Paste Range(Left(CHsize1, 2)).Select Next kui Application.ScreenUpdating = True End Sub [/pre2]
Ответов - 1
Мур'авейКа: попробуй отступами пользоваться в коде
полная версия страницы