Макрос Excel скопируйте те же записи один раз в другой лист бумаги

Question

Я действительно новичок в VBA Excel.

Допустим, у меня есть бумага 1, в столбце A много типов предупреждений, а в столбце B место, где это произошло (я работаю в охранной компании). Что мне нужно сделать, это прочитать столбец A, а затем столбец B; если значение столбца A превышает 50 раз, поместите его в документ 2, не указав X раз, только если столбец B отличается.

Пример :

Col A :                                  Col B : 
Alert named 1 (50 times repeated)        Chicago
Alert named 1 (50 times repeated)        Tunis
Alert named 1 (50 times repeated)        Tunis
Alert named 1 (50 times repeated)        Tunis
Alert named 2                            ohoa

В статье 2:

Col A :           Col B :
Alert named 1     Chicago
Alert named 1     Tunis

Answer 1

Я не думаю, что это возможно сделать только формулой. Вот макрос, который я написал и протестировал, который перечислит любой Alert Type вместе с Location на Sheet 2 если это происходит 50 times in a row на Sheet 1 .

Откройте VBE ALT+F11, вставьте новый Module 1 скопируйте и вставьте приведенный ниже код.

Sub Main()

    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Sheets(1)
    Set ws2 = Sheets(2)

    ReDim arr(0) As String
    Dim i As Long
    For i = 1 To ws1.Range("A" & Rows.Count).End(xlUp).Row
        arr(i - 1) = ws1.Range("A" & i) & "^" & ws1.Range("B" & i)
        ReDim Preserve arr(UBound(arr) + 1)
    Next i

    RemoveDuplicate arr
    ReDim Preserve arr(UBound(arr) - 1)

    Dim j As Long, cnt As Long: cnt = 0
    For i = LBound(arr) To UBound(arr)
        For j = 1 To ws1.Range("A" & Rows.Count).End(xlUp).Row
            If arr(i) = ws1.Range("A" & j) & "^" & ws1.Range("B" & j) Then cnt = cnt + 1
        Next j
        If cnt > 50 Then
            ws2.Range("A" & ws2.Range("A" & Rows.Count).End(xlUp).Row + 1) = Split(arr(i), "^")(0)
            ws2.Range("B" & ws2.Range("B" & Rows.Count).End(xlUp).Row + 1) = Split(arr(i), "^")(1)
        End If
        cnt = 0
    Next i
    ws2.Columns.AutoFit
End Sub

Private Sub RemoveDuplicate(ByRef StringArray() As String)
    Dim lowBound$, UpBound&, A&, B&, cur&, tempArray() As String
    If (Not StringArray) = True Then Exit Sub
    lowBound = LBound(StringArray): UpBound = UBound(StringArray)
    ReDim tempArray(lowBound To UpBound)
    cur = lowBound: tempArray(cur) = StringArray(lowBound)
    For A = lowBound + 1 To UpBound
        For B = lowBound To cur
            If LenB(tempArray(B)) = LenB(StringArray(A)) Then
                If InStrB(1, StringArray(A), tempArray(B), vbBinaryCompare) = 1 Then Exit For
            End If
        Next B
        If B > cur Then cur = B: tempArray(cur) = StringArray(A)
    Next A
    ReDim Preserve tempArray(lowBound To cur): StringArray = tempArray
End Sub

Нажмите F5 или Run » Run Sub и проверьте результаты в Sheet 2