☰

Excel 宏将相同的条目复制到另一张纸上

tag-icon • tag-icon microsoft-excel worksheet-function vba
Excel 宏将相同的条目复制到另一张纸上

我对 VBA Excel 还很陌生。

假设我有一张试卷，其中 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

答案1

我认为仅使用公式无法做到这一点。这是我编写并测试的一个宏，它将列出任何内容Alert Type以及出现在的Location内容。Sheet 250 times in a rowSheet 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

相关内容