- Jan 24, 2011
- Office Version
I have been given this code that I am sure a lot of you can read and understand what it does. The problem is whatever the file size I use it on it only completes about 3/4s of it. If the file has 10 rows it only does about 7 of it or if it has 1000 rows it only completes about 700. Any ideas on why this could be? Thanks.
Sub Dazzawm() Application.ScreenUpdating = False Dim Rng As Range Dim Dn As Range Dim Twn As String Dim Q Dim K Dim ac As Long Dim c As Long Dim tot As Long Set Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp)) With CreateObject("scripting.dictionary") .CompareMode = vbTextCompare For Each Dn In Rng Twn = Dn & Dn(, 2) & Dn(, 3) If Not .Exists(Twn) Then .Add Twn, Array(Dn, Dn(, 2), Dn(, 3), Dn(, 4), Dn(, 5), Dn(, 6), Dn(, 7)) Else Q = .Item(Twn) Q(3) = Application.Min(Q(3), Dn(, 4)) Q(4) = Application.Max(Q(4), Dn(, 5)) .Item(Twn) = Q End If Next For Each K In .Keys tot = tot + (.Item(K)(4) - .Item(K)(3)) Next K ReDim ray(1 To tot + .Count, 1 To 7) For Each K In .Keys For ac = .Item(K)(3) To .Item(K)(4) c = c + 1 ray(c, 1) = .Item(K)(0) ray(c, 2) = .Item(K)(1) ray(c, 3) = .Item(K)(2) ray(c, 4) = ac ray(c, 5) = .Item(K)(5) ray(c, 6) = .Item(K)(6) Next ac Next K Range("H2").Resize(tot, 6) = ray End With Range("A1:D1").Select Selection.Copy Range("H1").Select ActiveSheet.Paste Application.CutCopyMode = False Range("F1:G1").Select Selection.Copy Range("L1").Select ActiveSheet.Paste Application.CutCopyMode = False Columns("A:G").Select Selection.Delete Shift:=xlToLeft Cells.Select Cells.EntireColumn.AutoFit Columns("C:C").Select Selection.NumberFormat = "0.0" Range("A1").Select Application.ScreenUpdating = True End Sub