使“每个”循环更快

我已经做了下面的代码，但是需要很长时间才能完成。 我想知道是否有更快的方法。 如果与C2：K280中的任何单元匹配，我想从范围M2：M60复制格式（BG颜色）。 我可以做条件格式，但因为我需要input60多个可能会改变的项目，希望我可以使用VBA。

Sub CopyColors() Dim FoundCell As Range Dim Search As String Dim Searchrng As Range, cell As Range Set Searchrng = Sheets("Tally").Range("M2:M60") For Each cell In Searchrng For Each FoundCell In Sheets("Tally").Range("C2:K280") If FoundCell = cell Then cell.Copy FoundCell.PasteSpecial xlPasteFormats Else End If Next FoundCell Next cell Range("C2").Select End Sub 

-Cr1kk0

Answer 1

尝试这个。 它应该是瞬间的：

 Sub CopyColors() Dim i&, j&, k&, m, n, s As Range, f As Range Set s = [tally!m2:m60] Set f = [tally!c2:k280] m = s.Value2 n = f.Value2 For k = 1 To UBound(m) With s(k) For i = 1 To UBound(n, 1) For j = 1 To UBound(n, 2) If LenB(m(k, 1)) Then If LenB(n(i, j)) Then If m(k, 1) = n(i, j) Then f(i, j).Interior.Color = .DisplayFormat.Interior.Color End If End If End If Next Next End With Next End Sub 

Answer 2

我会认为，在内存中处理数组块块将是最快的路线，但这要么通过几毫秒的连接或击败嵌套的For ... Next循环通过数组。

 Sub Find_FindNext_Colors() Dim rTHIS As Range, rTHAT As Range, rTHOSE As Range Debug.Print Timer With Worksheets("Tally") With .Range("C2:K280, M2:M280") '<~~in the union, M has to be same size as C:K For Each rTHIS In .Parent.Range("M2:M60") '<~~only M2:M60 Set rTHAT = .Find(What:=rTHIS.Value2, After:=.Parent.Range("M60"), LookAt:=xlWhole, _ SearchOrder:=xlByColumns, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False) Set rTHOSE = rTHAT Do While rTHAT.Column < rTHIS.Column Set rTHOSE = Union(rTHOSE, rTHAT) Set rTHAT = .FindNext(After:=rTHAT) Loop rTHOSE.Interior.Color = rTHIS.DisplayFormat.Interior.Color Next rTHIS End With End With Debug.Print Timer End Sub 

我相信通过分组而不是单独分配Range.Interior.Color属性可以节省几毫秒的时间 。