Results 1 to 1 of 1
  1. #1
    Join Date
    Feb 2014
    Posts
    1

    Question Unanswered: Running of procedure takes a long time

    Here my code:

    Private Sub CopyRanges()

    Sheets("Test2").Activate

    Application.ScreenUpdating = False

    Application.DisplayAlerts = False

    Range(ActiveSheet.Columns("A"), ActiveSheet.Columns("A").End(xlDown)).Value = Range(Sheets("Test1").Columns(2), Sheets("Test1").Columns(2).End(xlDown)).Value

    Range(ActiveSheet.Columns("B"), ActiveSheet.Columns("B").End(xlDown)).Value = Range(Sheets("Test1").Columns(23), Sheets("Test1").Columns(23).End(xlDown)).Value

    Range(ActiveSheet.Columns("C:D"), ActiveSheet.Columns("C:D").End(xlDown)).Value = Range(Sheets("Test1").Columns(3), Sheets("Test1").Columns(3).End(xlDown)).Value

    Range(ActiveSheet.Columns("E:F"), ActiveSheet.Columns("E:F").End(xlDown)).Value = Range(Sheets("Test1").Columns(4), Sheets("Test1").Columns(4).End(xlDown)).Value

    Range(ActiveSheet.Columns("G:H"), ActiveSheet.Columns("G:H").End(xlDown)).Value = Range(Sheets("Test1").Columns(5), Sheets("Test1").Columns(5).End(xlDown)).Value

    Range(ActiveSheet.Columns("I:J"), ActiveSheet.Columns("I:J").End(xlDown)).Value = Range(Sheets("Test1").Columns(6), Sheets("Test1").Columns(6).End(xlDown)).Value

    Range(ActiveSheet.Columns("K:L"), ActiveSheet.Columns("K:L").End(xlDown)).Value = Range(Sheets("Test1").Columns(7), Sheets("Test1").Columns(7).End(xlDown)).Value

    Range(ActiveSheet.Columns("M:N"), ActiveSheet.Columns("M:N").End(xlDown)).Value = Range(Sheets("Test1").Columns(8), Sheets("Test1").Columns(8).End(xlDown)).Value

    Range(ActiveSheet.Columns("O:P"), ActiveSheet.Columns("O:P").End(xlDown)).Value = Range(Sheets("Test1").Columns(9), Sheets("Test1").Columns(9).End(xlDown)).Value

    Range(ActiveSheet.Columns("Q:R"), ActiveSheet.Columns("Q:R").End(xlDown)).Value = Range(Sheets("Test1").Columns(10), Sheets("Test1").Columns(10).End(xlDown)).Value

    Range(ActiveSheet.Columns("S:T"), ActiveSheet.Columns("S:T").End(xlDown)).Value = Range(Sheets("Test1").Columns(11), Sheets("Test1").Columns(11).End(xlDown)).Value

    Range(ActiveSheet.Columns("U:V"), ActiveSheet.Columns("U:V").End(xlDown)).Value = Range(Sheets("Test1").Columns(12), Sheets("Test1").Columns(12).End(xlDown)).Value

    Range(ActiveSheet.Columns("W:X"), ActiveSheet.Columns("W:X").End(xlDown)).Value = Range(Sheets("Test1").Columns(13), Sheets("Test1").Columns(13).End(xlDown)).Value

    Range(ActiveSheet.Columns("Y:Z"), ActiveSheet.Columns("Y:Z").End(xlDown)).Value = Range(Sheets("Test1").Columns(14), Sheets("Test1").Columns(14).End(xlDown)).Value

    Dim rCell As Range

    Dim rRng As Range

    For Each rCell In Range("C1:D800")

    If rCell.Value = "Maximum accomodation in room is" Then

    If rRng Is Nothing Then

    Set rRng = rCell

    Else

    Set rRng = Application.Union(rRng, rCell)

    End If

    End If

    Next

    rRng.Offset(, 0).Select
    Selection.EntireRow.Unmerge
    Selection.HorizontalAlignment = xlGeneral

    Columns("A").Replace What:=",99", Replacement:="", LookAt:= _
    xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False

    Columns("A").Replace What:=",00", Replacement:="", LookAt:= _
    xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False

    Range("B5").Select

    Application.DisplayAlerts = True

    Application.ScreenUpdating = True

    Application.Run "ResizeAll"

    End Sub


    Vba works well except for timing. Procedure takes between 7-10 minutes and could not find a solution to reduce the time.

    test1 file:
    https://www.imageupload.co.uk/image/BjE3

    test2 file:
    https://www.imageupload.co.uk/image/BjEL

    Thanks in advance
    Last edited by zrs; 03-04-17 at 04:49.

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •