Running of procedure takes a long time

[candeniz]

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

 

[mole999]

My right head is not on properly, I'm having trouble visualizing what you want to do

The first part looks as if you are taking individual columns from Test1 and Pasting in Test2. Are you doing this line by line or starting at one row down to say 200 as a single hit

moving to something like this would be faster

Sheet1.Range("A1:A" & LastRow).Copy Destination:=Sheet2.Range("B1")

defining the LastRow with

Dim LastRow As Long
LastRow = Range("A65536").End(xlUp).Row

 

[Caleeco]

^^ As mole suggested, defining the value for the last row ONCE and then using that would be much quicker. The first few instrcutions of your code can be written in this stle:

Private Sub CopyRanges()
Dim wsTest2 As Worksheet, wsTest1 As Worksheet
Dim lr As Long


Set wsTest2 = ActiveWorkbook.Sheets("Test2")
Set wsTest1 = ActiveWorkbook.Sheets("Test1")


With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With


wsTest2.Activate
lr = wsTest1.UsedRange.Rows(wsTest1.UsedRange.Rows.Count).Row


wsTest2.Range("A1:A" & lr).Value = wsTest1.Range("B1:B" & lr).Value
wsTest2.Range("B1:B" & lr).Value = wsTest1.Range("W1:W" & lr).Value
wsTest2.Range("C1:D" & lr).Value = wsTest1.Range("C1:C" & lr).Value
'and so on...
End Sub

I'm not entirely sure what the last half of the code is attempting to do? Also, couple of questions:
1. Does Test2 need to be cleared of data before copying from Test1?
2. Are the number of rows used always the same?
3. If you could explain in words what the last part of the code is trying to achieve we could code something perhaps more efficient.

Thanks
Caleeco

 

[MARK858]

Just as a bit more you are looping though 1600 cells and if the criteria is met selecting the cell which you don't need to do so

rRng.Offset(, 0).Select
Selection.EntireRow.Unmerge

becomes

rRng.Offset(, 0).EntireRow.Unmerge

I am currently not seeing what the Union is trying to accomplish as you are setting rRng to rCell so doing a Union with itself.

Just to go a bit further with what mole999 posted use

LastRow = Range("A" & Rows.Count).End(xlUp).Row

Rather tnan

LastRow = Range("A65536").End(xlUp).Row

As it will be 100% correct for all versions

 

[candeniz]

Thanks Caleeco for your reply. Test1 includes my row data of contract and may have more rows (sure not much as 65536) regarding the room types of hotel (here 2 only). Test2 is rearrangement table of test1 rows since my 3rd party Agency software can auto read datas by this version. I am trying to get test1 datas priority than reorganizing it adaptable to my Agency software. So my code is bringing datas on test2, changing the row adresses and merging pricing rows can see in the links of first post down below. Column A may include room type + accommodations types, Column B inc. board type, C:D inc. allotment number (left blank here) + prices. The new room specificitaions starts after blank rows (23). Hope I did a proper explonation.

 

[candeniz]

^^ As mole suggested, defining the value for the last row ONCE and then using that would be much quicker. The first few instrcutions of your code can be written in this stle:

Private Sub CopyRanges()
Dim wsTest2 As Worksheet, wsTest1 As Worksheet
Dim lr As Long


Set wsTest2 = ActiveWorkbook.Sheets("Test2")
Set wsTest1 = ActiveWorkbook.Sheets("Test1")


With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With


wsTest2.Activate
lr = wsTest1.UsedRange.Rows(wsTest1.UsedRange.Rows.Count).Row


wsTest2.Range("A1:A" & lr).Value = wsTest1.Range("B1:B" & lr).Value
wsTest2.Range("B1:B" & lr).Value = wsTest1.Range("W1:W" & lr).Value
wsTest2.Range("C1:D" & lr).Value = wsTest1.Range("C1:C" & lr).Value
'and so on...
End Sub

I'm not entirely sure what the last half of the code is attempting to do? Also, couple of questions:
1. Does Test2 need to be cleared of data before copying from Test1?
2. Are the number of rows used always the same?
3. If you could explain in words what the last part of the code is trying to achieve we could code something perhaps more efficient.

Thanks
Caleeco

I applied your code and works well becomes much more faster than previous. I kept the rest of my code as it was and the result is perfect as I requested. Than you very much indeed.