Developing.ru

Код: Выделить всё

 
Sub Macros()
dim sovp as long
dim kolsovp as long
kolsovp = 0
While Sheets("name_page").Cells(q, 1) <> ""
for i = 1 to 3
if Sheets("name_page").Cells(q, 1).Value = Sheets("SAP").Cells(q, i+1).Value then
sovp = Sheets("SAP").Cells(q, i+1).Value and kolsovp=kolsovp +1
end if
Sheets("name_page").Cells(q, 5).Value = sovp
Sheets("name_page").Cells(q, 6).Value = kolsovp
next i
Wend
End Sub

Код: Выделить всё

Sub updateExcel()
Dim cn As New ADODB.Connection, sVar$
'строка подключения к источнику данных - текущий, сохраненный(!) файл Excel
sVar = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" + ThisWorkbook.Path + "\" + _
ThisWorkbook.Name + ";Extended Properties=""Excel 8.0;HDR=Yes"";"
'--------------------------------------------
'запрос в текущем файле выполняется гораздо дольше чем во внешнем
'для внешнего файла строка подключения может выглядеть так:
sVar = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\Book1.xls;Extended Properties=""Excel 8.0;HDR=Yes"";"
'--------------------------------------------
'Константа с текстом исполняемого запроса на обновление:
Const sqlUp$ = "UPDATE [Лист1$A1:G50000] as d " + _
"SET d.W5 = IIf([w1]=[w2],'1-2; ','') & IIf([w1]=[w3],'1-3; ','') & IIf([w1]=[w4],'1-4; ','') & " + _
"IIf([w2]=[w3],'2-3; ','') & IIf([w2]=[w4],'2-4; ','') & IIf([w3]=[w4],'3-4; ',''), " + _
"d.W6 = IIf([w1]=[w2],1,0)+IIf([w1]=[w3],1,0)+IIf([w1]=[w4],1,0)+IIf([w2]=[w3],1,0)" + _
"+IIf([w2]=[w4],1,0)+IIf([w3]=[w4],1,0);"
' [Лист1$A1:G50000]  - имя листа и используемый диапазон
'--------------------------------------------
'код открывает соединение с источником данных, выполняет запрос на обновление,
'закрывает соединение и очищает использовавшуюся память
Set cn = New Connection
cn.Open sVar
cn.Execute sqlUp
cn.Close:       Set cn = Nothing
End Sub

Код: Выделить всё

Public Sub СЧЁТЧИК_СОВПАДЕНИЙ()
' предполагается расположение исходного массива данных в ячейках
' A1 : Dn активого листа и результата в столбцах F : I
    Dim n As Long        'номер последней строки данных
    Dim k As Long        'номер очередной формируемой строки отчёта о совпадениях
    Dim i As Long
    Dim j As Long
    Dim m As Long        'номер формируемой колонки отчёта о совпадениях
    Dim v As Double      'тестируемое число
    'В предположении что под массивом данных ничего нет
    n = Cells(Cells.Rows.Count, 1).End(xlUp).Row 'последняя строка исходной таблицы
    k = 1
    Application.ScreenUpdating = False
    For j = 1 To 4
         For i = 1 To n
              v = Cells(i, j).Value
              If Application.WorksheetFunction.CountIf([F:I], v) = 0 Then
                  For m = 1 To 4
                       If m <> j Then
                            If Application.WorksheetFunction.CountIf(Cells(1, m).Resize(n, 1), v) > 0 Then
                                  Cells(k, 5 + m) = v
                            End If
                       Else
                            Cells(k, 5 + m) = v
                       End If
                   Next m
                   If Application.WorksheetFunction.Sum(Range(Cells(k, 6), Cells(k, 9))) = v Then
                        Range(Cells(k, 6), Cells(k, 9)).ClearContents
                   Else
                        k = k + 1
                   End If
              End If
         Next i
   Next j
   Application.ScreenUpdating = True
End Sub