Доброй ночи, друзья! Прошу помощи в создании макроса для решения задачи по анализу совпадений. Дано: массив с различным количеством столбцов (от 2 до 10 и более) с числовыми значениями. Необходимо объединить их в 1 столбец, а в следующих столбцах указать количество повторений значений в каждом столбце данного массива. Возможно ли создать макрос для решения такой задачи? Заранее благодарен за помощь.
Доброй ночи, друзья! Прошу помощи в создании макроса для решения задачи по анализу совпадений. Дано: массив с различным количеством столбцов (от 2 до 10 и более) с числовыми значениями. Необходимо объединить их в 1 столбец, а в следующих столбцах указать количество повторений значений в каждом столбце данного массива. Возможно ли создать макрос для решения такой задачи? Заранее благодарен за помощь.Evgen2350
n = 0 For i = 1 To ra flg = False For j = 1 To n If abc(j) = a(i, 1) Then flg = True End If Next j If Not flg Then n = n + 1 ReDim Preserve abc(n) abc(n) = a(i, 1) End If Next i
For i = 1 To rb flg = False For j = 1 To n If abc(j) = b(i, 1) Then flg = True End If Next j If Not flg Then n = n + 1 ReDim Preserve abc(n) abc(n) = b(i, 1) End If Next i
For i = 1 To rc flg = False For j = 1 To n If abc(j) = c(i, 1) Then flg = True End If Next j If Not flg Then n = n + 1 ReDim Preserve abc(n) abc(n) = c(i, 1) End If Next i
' сортировка ip адресов, если не нужна, удалите For i = 1 To n - 1 For j = i + 1 To n If abc(i) > abc(j) Then tmp = abc(i) abc(i) = abc(j) abc(j) = tmp End If Next j Next i ' конец сортировки
Columns("F:I").ClearContents For i = 1 To n Cells(i, 6).Value = abc(i) cnt = 0 For j = 1 To ra If abc(i) = a(j, 1) Then cnt = cnt + 1 End If Next j Cells(i, 7).Value = cnt cnt = 0 For j = 1 To rb If abc(i) = b(j, 1) Then cnt = cnt + 1 End If Next j Cells(i, 8).Value = cnt cnt = 0 For j = 1 To rc If abc(i) = c(j, 1) Then cnt = cnt + 1 End If Next j Cells(i, 9).Value = cnt Next i Application.ScreenUpdating = True End Sub
[/vba]
[vba]
Код
Option Base 1 Sub qwerty() Dim a() As Variant Dim b() As Variant Dim c() As Variant Dim abc() As Variant
n = 0 For i = 1 To ra flg = False For j = 1 To n If abc(j) = a(i, 1) Then flg = True End If Next j If Not flg Then n = n + 1 ReDim Preserve abc(n) abc(n) = a(i, 1) End If Next i
For i = 1 To rb flg = False For j = 1 To n If abc(j) = b(i, 1) Then flg = True End If Next j If Not flg Then n = n + 1 ReDim Preserve abc(n) abc(n) = b(i, 1) End If Next i
For i = 1 To rc flg = False For j = 1 To n If abc(j) = c(i, 1) Then flg = True End If Next j If Not flg Then n = n + 1 ReDim Preserve abc(n) abc(n) = c(i, 1) End If Next i
' сортировка ip адресов, если не нужна, удалите For i = 1 To n - 1 For j = i + 1 To n If abc(i) > abc(j) Then tmp = abc(i) abc(i) = abc(j) abc(j) = tmp End If Next j Next i ' конец сортировки
Columns("F:I").ClearContents For i = 1 To n Cells(i, 6).Value = abc(i) cnt = 0 For j = 1 To ra If abc(i) = a(j, 1) Then cnt = cnt + 1 End If Next j Cells(i, 7).Value = cnt cnt = 0 For j = 1 To rb If abc(i) = b(j, 1) Then cnt = cnt + 1 End If Next j Cells(i, 8).Value = cnt cnt = 0 For j = 1 To rc If abc(i) = c(j, 1) Then cnt = cnt + 1 End If Next j Cells(i, 9).Value = cnt Next i Application.ScreenUpdating = True End Sub
Public Sub CreateReport() Dim pDict As Object, pSheet As Worksheet Dim vData As Variant, arrOut() As Variant Dim iRow As Long, iCol As Long, idRow As Long Dim LRow As Long, LCol As Long, curVal As Variant Set pSheet = ActiveSheet Set pDict = CreateObject("Scripting.Dictionary") vData = pSheet.UsedRange.Value: idRow = 0 LRow = UBound(vData): LCol = UBound(vData, 2) ReDim arrOut(1 To LRow * LCol, 1 To LCol + 1) For iCol = 1 To LCol For iRow = 1 To LRow curVal = Trim$(CStr(vData(iRow, iCol))) If curVal <> "" Then If pDict.Exists(curVal) Then idRow = pDict(curVal) arrOut(idRow, iCol + 1) = arrOut(idRow, iCol + 1) + 1 Else idRow = idRow + 1 pDict.Add curVal, idRow arrOut(idRow, 1) = curVal arrOut(idRow, iCol + 1) = 1& End If End If Next Next Set pSheet = Worksheets.Add pSheet.Range(pSheet.Cells(1, 1), pSheet.Cells(LRow * LCol, LCol + 1)).Value = arrOut pSheet.Range(pSheet.Cells(1, 1), pSheet.Cells(LRow * LCol, LCol + 1)).EntireColumn.AutoFit End Sub
[/vba] С наступающим!
Доброе утро. Ещё вариант [vba]
Код
Public Sub CreateReport() Dim pDict As Object, pSheet As Worksheet Dim vData As Variant, arrOut() As Variant Dim iRow As Long, iCol As Long, idRow As Long Dim LRow As Long, LCol As Long, curVal As Variant Set pSheet = ActiveSheet Set pDict = CreateObject("Scripting.Dictionary") vData = pSheet.UsedRange.Value: idRow = 0 LRow = UBound(vData): LCol = UBound(vData, 2) ReDim arrOut(1 To LRow * LCol, 1 To LCol + 1) For iCol = 1 To LCol For iRow = 1 To LRow curVal = Trim$(CStr(vData(iRow, iCol))) If curVal <> "" Then If pDict.Exists(curVal) Then idRow = pDict(curVal) arrOut(idRow, iCol + 1) = arrOut(idRow, iCol + 1) + 1 Else idRow = idRow + 1 pDict.Add curVal, idRow arrOut(idRow, 1) = curVal arrOut(idRow, iCol + 1) = 1& End If End If Next Next Set pSheet = Worksheets.Add pSheet.Range(pSheet.Cells(1, 1), pSheet.Cells(LRow * LCol, LCol + 1)).Value = arrOut pSheet.Range(pSheet.Cells(1, 1), pSheet.Cells(LRow * LCol, LCol + 1)).EntireColumn.AutoFit End Sub