如何应用“发现”宏 [英] How to apply "found" Macro

问题描述

我有三个宏比较两列

我使用的一个宏在一个大文件上变化较慢，但是

The one I am using is vary slow on a large file but works

Sub MatchPermissionGiverAndTarget()
Dim LastRow As Long
Dim ws As Excel.Worksheet

GoFast False

Set ws = ActiveWorkbook.Sheets("Helper")
LastRow = ws.Range("A" & ws.Rows.count).End(xlUp).Row

Range("E1").EntireColumn.Insert
Range("E1").FormulaR1C1 = "name"

With ws.Range("E2:E" & LastRow)
    .Formula = "=INDEX(B:B,MATCH($D2,$B:$B,0))"
    .Value = .Value
End With

Columns("D:D").EntireColumn.Delete

GoFast True

End Sub

这个我发现的这个@mehow这里： 2列的快速比较方法

And this one I found by @mehow Here: Fast compare method of 2 columns

但是我不知道如何应用它，所以它剂量了第一个剂量

But I can not figure out how to apply it so it dose what the first one dose

对此有任何帮助赞赏

Sub Main()
Application.ScreenUpdating = False

Dim stNow As Date
stNow = Now

Dim arr As Variant
arr = Range("B2:A" & Range("B" & Rows.Count).End(xlUp).Row).Value


 Range("E1").EntireColumn.Insert
 Range("E1").FormulaR1C1 = "name"

Dim varr As Variant
varr = Range("D2:D" & Range("D" & Rows.Count).End(xlUp).Row).Value

Dim x, y, match As Boolean
For Each x In arr
    match = False
    For Each y In varr
        If x = y Then match = True
    Next y
    If Not match Then
        Range("D" & Range("D" & Rows.Count).End(xlUp).Row + 1) = x
    End If
Next

 Columns("D:D").EntireColumn.Delete

Debug.Print DateDiff("s", stNow, Now)
Application.ScreenUpdating = True
End Sub

或者这个来自@Reafidy的同一个线程

Or This one from same thread by @Reafidy

Sub HTH()

Application.ScreenUpdating = False

With Range("E2", Cells(Rows.Count, "E").End(xlUp)).Offset(, 1)
    .Formula = "=VLOOKUP(B2,D:D,1,FALSE)"
    .Value = .Value
    .SpecialCells(xlCellTypeConstants, 16).Offset(, -1).Copy Range("D" & Rows.Count).End(xlUp).Offset(1)
    .ClearContents
End With

Application.ScreenUpdating = True

End Sub

推荐答案

尝试这一个：

Sub Main()
    Dim ws As Worksheet
    Dim stNow As Date
    Dim lastrow As Long, lastrowB As Long
    Dim match As Boolean
    Dim k As Long
    Dim arr, varr, v, a, res

    Application.ScreenUpdating = False

    stNow = Now

    Set ws = ActiveWorkbook.Sheets("Helper")

    With ws
        lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
        lastrowB = .Range("B" & .Rows.Count).End(xlUp).Row

        arr = .Range("B2:B" & lastrowB).Value
        varr = .Range("D2:D" & lastrow).Value

        .Range("E1").EntireColumn.Insert
        .Range("E1").FormulaR1C1 = "name"
    End With

    k = 1

    ReDim res(1 To lastrow, 1 To 1)

    For Each v In varr
        match = False
        'if value from column D (v) contains in column B
        For Each a In arr
            If a = v Then
                match = True
                Exit For
            End If
        Next a

        If match Then
            res(k, 1) = v
        Else
            res(k, 1) = CVErr(xlErrNA)
        End If
        k = k + 1
    Next v

    With ws
        .Range("E2:E" & lastrow).Value = res
        .Range("D:D").Delete
    End With


    Debug.Print DateDiff("s", stNow, Now)
    Application.ScreenUpdating = True
End Sub

这篇关于如何应用“发现”宏的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！