Macro not executing itself completely - vba

So i have the following macro
Private Sub Worksheet_Change(ByVal Target As Range)
BeginRow = 178
EndRow = 178
ChkCol = 8
For RowCnt = BeginRow To EndRow
If IsError(Sheet1.Cells(RowCnt, ChkCol).Value) Then
Sheet1.Cells(169, ChkCol).EntireRow.Hidden = True
Sheet1.Cells(170, ChkCol).EntireRow.Hidden = True
Sheet1.Cells(171, ChkCol).EntireRow.Hidden = True
Sheet1.Cells(172, ChkCol).EntireRow.Hidden = True
Sheet1.Cells(173, ChkCol).EntireRow.Hidden = True
Sheet1.Cells(174, ChkCol).EntireRow.Hidden = True
Sheet1.Cells(175, ChkCol).EntireRow.Hidden = True
Sheet1.Cells(176, ChkCol).EntireRow.Hidden = True
Sheet1.Cells(177, ChkCol).EntireRow.Hidden = True
Sheet1.Cells(178, ChkCol).EntireRow.Hidden = True
Sheet1.Cells(179, ChkCol).EntireRow.Hidden = True
End If
Next RowCnt
For RowCnt = BeginRow To EndRow
If Not IsError(Sheet1.Cells(RowCnt, ChkCol).Value) Then
Sheet1.Cells(169, ChkCol).EntireRow.Hidden = False
Sheet1.Cells(170, ChkCol).EntireRow.Hidden = False
Sheet1.Cells(171, ChkCol).EntireRow.Hidden = False
Sheet1.Cells(172, ChkCol).EntireRow.Hidden = False
Sheet1.Cells(173, ChkCol).EntireRow.Hidden = False
Sheet1.Cells(174, ChkCol).EntireRow.Hidden = False
Sheet1.Cells(175, ChkCol).EntireRow.Hidden = False
Sheet1.Cells(176, ChkCol).EntireRow.Hidden = False
Sheet1.Cells(177, ChkCol).EntireRow.Hidden = False
Sheet1.Cells(178, ChkCol).EntireRow.Hidden = False
Sheet1.Cells(179, ChkCol).EntireRow.Hidden = False
End If
Next RowCnt
End Sub
You could probably do this a lot prettier, but i am quite new to VBA.
The formula H178 has the following input:
`=(H170+H171+H172+H173+H174+H175+H176+H177)/7`
However these cells H170, H171 etc. get their data from Sheet2
So i.e. when H170 is an error, H178 gives a #REF! which should automatically mean that the macro is runned, but it doesn't, unless if i double-click on the cell H178 and hit enter.
But if i i.e. change the cell H170 directly on sheet1, to =5/0 (which gives error) then the macro is runned.
What am i doing wrong?


You should place this code in the Worksheet_Calculate event in order to have it recalculate when the error is passed

Related

Excel VBA Macro - Out of Memory Error

I am having trouble when running a macro whereby I get an error, usually at the end, stating that it "Out of memory".
I've looked over a number of posts and followed recommendations to clear any variables and ensure that the code is "cleaner". However, the error still persists.
I have included the code below, any feedback would be greatly appreciated.
A summary of the purpose:
User clicks a button in a template (which is where the code resides)
Macro 1 cleans up the data that the user pastes into a template page.
A userform will appear after macro 1 which the user must input some data - customer name, contract numbers, etc.
Macro 2 runs when the userform button is submitted which creates a new workbook containing all the data from the template (formatted in macro1) and the data from the form.
It then formats the data for printing with a logo, etc.
Macro 1
Private Sub ContractsClean()
Application.Visible = True
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.CutCopyMode = False
Sheets("Paste").Name = "Data"
Sheets("Data").Columns("A:B").EntireColumn.Delete
Dim x As Long, lastrow As Long
lastrow = Sheets("Data").Cells(Rows.Count, "A").End(xlUp).Row
'Clean the codes
For x = lastrow To 2 Step -1
If Len(Sheets("Data").Cells(x, 1)) > 9 Then
Sheets("Data").Cells(x, 1).Value = Right(Sheets("Data").Cells(x, 1).Value, 9)
End If
Next x
'Add the leading zero
Sheets("Data").Select
Range("A:A").Select
Dim Rng As Range
Dim bChanged As Boolean
Dim icol As Long
Dim sString As String
Dim iWSs As Long
iWSs = Workbooks.Count
If iWSs >= 1 Then
icol = Selection.Column
lastrow = Cells(Rows.Count, icol).End(xlUp).Row
For Each Rng In Selection
If TypeName(Rng.Value) = "Double" Then
If Left(Rng.Value, 1) = "9" Then
Rng = "'0" & Rng.Value
bChanged = True
End If
End If
If TypeName(Rng.Value) = "String" Then
If Left(Rng.Value, 3) = "09-" Then
sString = Rng.Value
sString = "'" & Replace(sString, "-", "")
Rng.Value = sString
bChanged = True
End If
End If
If Rng.Errors(xlNumberAsText).Value = True And bChanged = True Then Rng.Errors(xlNumberAsText).Ignore = True
If Rng.Row = lastrow Then Exit For
Next Rng
End If
If iWSs >= 1 Then
icol = Selection.Column
lastrow = Cells(Rows.Count, icol).End(xlUp).Row
For Each Rng In Selection
If TypeName(Rng.Value) = "Double" Then
If Left(Rng.Value, 1) = "8" Then
Rng = "'0" & Rng.Value
bChanged = True
End If
End If
If TypeName(Rng.Value) = "String" Then
If Left(Rng.Value, 3) = "08-" Then
sString = Rng.Value
sString = "'" & Replace(sString, "-", "")
Rng.Value = sString
bChanged = True
End If
End If
If Rng.Errors(xlNumberAsText).Value = True And bChanged = True Then Rng.Errors(xlNumberAsText).Ignore = True
If Rng.Row = lastrow Then Exit For
Next Rng
End If
Rng = Empty
bChanged = Empty
icol = Empty
sString = Empty
iWSs = Empty
Sheets("Data").Columns("B").EntireColumn.Delete
Sheets("Data").Range("C1").Value = "Quantity"
Sheets("Data").Columns("D").EntireColumn.Delete
Sheets("Data").Columns("E").EntireColumn.Delete
Sheets("Data").Range("E:F").NumberFormat = "dd/mm/yyyy"
Dim ws As Worksheet
Set ws = Sheets("Data")
ws.Range("A:B").Locked = False
ws.Range("C:D").Locked = True
ws.Range("E:F").Locked = False
ws.Protect DrawingObjects:=True, Contents:=True, Scenarios:= _
True, AllowDeletingRows:=True, AllowFormattingCells:=True, AllowFiltering:=True, AllowInsertingRows:=True, Password:="Sanchez7"
'Completion message box
Dim Answer As String
Dim MyNote As String
'Place your text here
MyNote = "Cleanse complete. Do you want to create a local price agreement?"
'Display MessageBox
Answer = MsgBox(MyNote, vbQuestion + vbYesNo, "Action")
If Answer = vbNo Then
'Code for No button Press
Else
'Code for Yes button Press
ProposalForm.Show
End If
Answer = Empty
MyNote = Empty
lastrow = Empty
End Sub
Form Code
Private Sub CommandButton1_Click()
Dim sBuyGroup As String, sLPA As String, sRep As String, sStart As Date, sEnd As Date, sCurrency As String
Dim bExit As Boolean, sSort As String
sBuyGroup = txt_BuyGroup.Text
sLPA = txt_LPA.Text
sRep = txt_Rep.Text
sStart = txt_Start.Text
sEnd = txt_End.Text
sCurrency = ComboBox1.Value
If sBuyGroup = "" Then
bExit = True
MsgBox ("The account number cannot be blank")
End If
If sLPA = "" And bExit = False Then
bExit = True
MsgBox ("The carriage option cannot be blank")
End If
If sRep = "" And bExit = False Then
bExit = True
MsgBox ("The discount option cannot be blank")
End If
If bExit = False Then
Call CreateProposal(sBuyGroup, sLPA, sRep, sStart, sEnd, sCurrency)
Unload Me
Else
End If
sBuyGroup = Empty
sLPA = Empty
sRep = Empty
sStart = Empty
sEnd = Empty
sCurrency = Empty
End Sub
Macro 3 (which I believe is what causes the error)
Sub CreateProposal(sBuyGroup As String, sLPA As String, sRep As String, sStart As Date, sEnd As Date, sCurrency As String)
Dim picLogo As Picture
Set picLogo = Sheets("Info").Pictures("PH_LOGO")
'Copy data from original workbook
Dim exApp As Excel.Application
Set exApp = GetExcelObject()
exApp.Visible = True
Dim OGWB As Workbook
Set OGWB = ActiveWorkbook
OGWB.Sheets("Data").Range("A1:F15000").Copy
Dim wbProposal As Workbook
Set wbProposal = exApp.Workbooks.Add
wbProposal.Activate
wbProposal.Sheets("Sheet1").Range("A1").PasteSpecial xlPasteValues
wbProposal.Sheets("Sheet1").Name = "Raw"
exApp.CutCopyMode = False
exApp.Application.ScreenUpdating = False
'Copy the logo so we can close original workbook
wbProposal.Sheets.Add
wbProposal.Sheets("Sheet2").Name = "LPA"
OGWB.Sheets("Info").Pictures("PH_LOGO").Cut
wbProposal.Sheets("LPA").Paste
Selection.Name = "PH_LOGO"
wbProposal.Sheets("LPA").Pictures("PH_LOGO").Left = 20
wbProposal.Sheets("LPA").Pictures("PH_LOGO").Top = 13
'wbProposal.Sheets("LPA").Pictures("PH_LOGO").Width = Application.CentimetersToPoints(5.51)
'wbProposal.Sheets("LPA").Pictures("PH_LOGO").Height = Application.CentimetersToPoints(1.64)
wbProposal.Sheets("LPA").Range("A1").Select
Set picLogo = Nothing
exApp.CutCopyMode = False
wbProposal.Activate
wbProposal.Sheets("LPA").Select
'Set BG to all white
With wbProposal.Sheets("LPA").Cells.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'Add contact header
wbProposal.Sheets("LPA").Range("D2").Value = "performancehealth.co.uk"
wbProposal.Sheets("LPA").Range("D3").Value = "Main: +44 (0) 3448 730 035"
wbProposal.Sheets("LPA").Range("D4").Value = "Fax: +44 (0) 1623 557 769"
wbProposal.Sheets("LPA").Range("G2").Value = "Nunn Brook Road, Huthwaite,"
wbProposal.Sheets("LPA").Range("G3").Value = "Sutton-in-Ashfield"
wbProposal.Sheets("LPA").Range("G4").Value = "Nottinghamshire, NG17 2HU, UK"
With wbProposal.Sheets("LPA").Range("D2").Font
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0
.Bold = True
End With
With wbProposal.Sheets("LPA").Range("D3:D4,G2:G4").Font
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0.499984740745262
End With
wbProposal.Sheets("LPA").Range("G6").Value = "Local Price Agreement"
With wbProposal.Sheets("LPA").Range("G6").Font
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0
.Bold = True
.Size = 14
End With
'Arrange Column widths
wbProposal.Sheets("LPA").Columns("A").ColumnWidth = 2.5
wbProposal.Sheets("LPA").Columns("B").ColumnWidth = 13
wbProposal.Sheets("LPA").Range("B14").Value = "Item Code"
wbProposal.Sheets("LPA").Columns("C").ColumnWidth = 41.5
wbProposal.Sheets("LPA").Range("C14").Value = "Item Description"
wbProposal.Sheets("LPA").Columns("D:F").ColumnWidth = 12
wbProposal.Sheets("LPA").Range("D14").Value = "Sale UOM"
wbProposal.Sheets("LPA").Range("E14").Value = "Min Qty"
wbProposal.Sheets("LPA").Range("F14").Value = "Rate"
wbProposal.Sheets("LPA").Columns("G:H").ColumnWidth = 13.5
wbProposal.Sheets("LPA").Range("G14").Value = "Start Date"
wbProposal.Sheets("LPA").Range("H14").Value = "Expiry Date"
wbProposal.Sheets("LPA").Range("B14:H14").Font.Bold = True
With wbProposal.Sheets("LPA").Range("B14:H14").Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -4.99893185216834E-02
.PatternTintAndShade = 0
End With
'Fill out details from form
wbProposal.Sheets("LPA").Range("B8").Value = "Buying Group:"
wbProposal.Sheets("LPA").Range("B10").Value = "Sales Rep:"
wbProposal.Sheets("LPA").Range("B11").Value = "Currency:"
wbProposal.Sheets("LPA").Range("E8").Value = "LPA Number:"
wbProposal.Sheets("LPA").Range("E10").Value = "Start Date:"
wbProposal.Sheets("LPA").Range("E11").Value = "Expiry Date:"
wbProposal.Sheets("LPA").Range("B8:B11").Font.Bold = True
wbProposal.Sheets("LPA").Range("E8:E11").Font.Bold = True
wbProposal.Sheets("LPA").Range("C8").Value = sBuyGroup
wbProposal.Sheets("LPA").Range("C10").Value = sRep
wbProposal.Sheets("LPA").Range("C11").Value = sCurrency
wbProposal.Sheets("LPA").Range("F8").Value = sLPA
wbProposal.Sheets("LPA").Range("F10").Value = sStart
wbProposal.Sheets("LPA").Range("F11").Value = sEnd
sBuyGroup = Empty
sRep = Empty
sCurrency = Empty
sLPA = Empty
sStart = Empty
sEnd = Empty
'Import the list
Dim lastrow As Long
wbProposal.Sheets("Raw").Select
lastrow = wbProposal.Sheets("Raw").Cells(Rows.Count, "A").End(xlUp).Row
wbProposal.Sheets("Raw").Columns("C").Insert Shift:=xlToRight
wbProposal.Sheets("Raw").Range("F:G").NumberFormat = "dd/mm/yyyy"
wbProposal.Sheets("Raw").Range("E" & lastrow).NumberFormat = "£#,##0.00"
wbProposal.Sheets("Raw").Range("A2:G" & lastrow).Copy
wbProposal.Sheets("LPA").Select
wbProposal.Sheets("LPA").Range("B15").PasteSpecial xlPasteValuesAndNumberFormats
exApp.CutCopyMode = False
'Setup print area
lastrow = wbProposal.Sheets("LPA").Cells(Rows.Count, "B").End(xlUp).Row
wbProposal.Sheets("LPA").Range("F15:F" & lastrow).NumberFormat = "£#,##0.00"
wbProposal.Sheets("LPA").PageSetup.PrintArea = "$A$1:$H$" & lastrow
With wbProposal.Sheets("LPA").PageSetup
.PrintTitleRows = "$14:$14"
.PrintTitleColumns = ""
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 100
End With
'Redo the picture size (changes during column amendments
'wbProposal.Sheets("LPA").Pictures("PH_LOGO").Width = Application.CentimetersToPoints(5.51)
'wbProposal.Sheets("LPA").Pictures("PH_LOGO").Height = Application.CentimetersToPoints(1.64)
lastrow = Empty
exApp.DisplayAlerts = False
exApp.CutCopyMode = False
wbProposal.Sheets("LPA").Range("A1").Select
wbProposal.Sheets("Raw").Delete
exApp.DisplayAlerts = False
exApp.ScreenUpdating = True
OGWB.Close False
Set OGWB = Nothing
Set wbProposal = Nothing
Set exApp = Nothing
Application.Quit
End Sub
'-----------------------------------------------------------------------------
' Return an intance of Excel
' First tries to open an existing instance. If it fails, it will create an instance.
' If that fails too, then we return 'Nothing'
'-----------------------------------------------------------------------------
Public Function GetExcelObject() As Object
On Error Resume Next
Dim xlo As Object
' Try to get running instance of Excel
Set xlo = GetObject("Excel.Application")
If xlo Is Nothing Then
Set xlo = CreateObject("Excel.Application")
End If
Set GetExcelObject = xlo
End Function

Why does this simple macro (to hide rows) cause Excel to become unresponsive?

As part of a recent Transport Science project, I've been given a sheet with data from 7094 car crashes. In an attempt to filter out only the relevant data - in this case crashes involving pedestrians, fatalities or serious injuries - I tried adapting a macro I found online.
This is my first time dabbling in VBA, although I have some undergrad experience in C and Java (just in case this proves relevant somehow). The code is as follows:
Sub HideRows()
BeginRow = 2
EndRow = 7095
ChkCol = 10
For RowCnt = BeginRow To EndRow
If Cells(RowCnt, ChkCol).Value > 0 Or Cells(RowCnt, ChkCol + 1).Value > 0 Or Cells(RowCnt, ChkCol + 2).Value > 0 Then
Rows(RowCnt).EntireRow.Hidden = False
Else
Rows(RowCnt).EntireRow.Hidden = True
End If
Next RowCnt
End Sub
The problem is it causes Excel to become unresponsive. I can see the macro is performing the intended function, but I can't save or regain control over the program at the end.
Struggling with this is wasting a lot of time and I've got a feeling the problem (and subsequent fix) is very, very simple - hopefully.
Any advice will be greatly appreciated.

In addition to adding ScreenUpdating and EnableEvent booleans you can also refactor the code to only perform one hide / unhide operation (or two in this case), instead of doing it on each loop iteration, which will slow things down. Also you can turn off calculations (in case that affects things).
Option Explicit
Sub HideRows()
Dim BeginRow As Integer, EndRow As Integer, ChkCol As Integer
BeginRow = 2
EndRow = 7095
ChkCol = 10
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
Application.Calculation xl
Dim rHide As Range
Dim rShow As Range
For RowCnt = BeginRow To EndRow
If Cells(RowCnt, ChkCol).Value > 0 Or Cells(RowCnt, ChkCol + 1).Value > 0 Or Cells(RowCnt, ChkCol + 2).Value > 0 Then
If Not rHide Is Nothing Then
Set rHide = Cells(1, RowCnt)
Else
Set rHide = Union(rHide, Cells(1, RowCnt))
End If
Else
If Not rShow Is Nothing Then
Set rShow = Cells(1, RowCnt)
Else
Set rShow = rShow(rHide, Cells(1, RowCnt))
End If
End If
Next RowCnt
'show / hide appropriate ranges
rHide.EntireRow.Visible = False
rShow.EntireRow.Visible = True
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub

To speed this code up, you simply need to add Application.ScreenUpdating = False to the start and Application.ScreenUpdating = True at the end
Sub HideRows()
BeginRow = 2
EndRow = 7095
ChkCol = 10
Application.ScreenUpdating = False
For RowCnt = BeginRow To EndRow
If Cells(RowCnt, ChkCol).Value > 0 Or Cells(RowCnt, ChkCol + 1).Value > 0 Or Cells(RowCnt, ChkCol + 2).Value > 0 Then
Rows(RowCnt).EntireRow.Hidden = False
Else
Rows(RowCnt).EntireRow.Hidden = True
End If
Next RowCnt
Application.ScreenUpdating = True
End Sub
Now, you may also have some events or conditional formats that trigger each time the sheet is updated. If so, also include Application.EnableEvents = False at the beginning and turn them back on at the end of the loop.
And if you really wanted, you could simplify your Boolean checks by simply saying:
If Cells(RowCnt, ChkCol).Value Or Cells(RowCnt, ChkCol + 1).Value Or Cells(RowCnt, ChkCol + 2).Value 0 Then
because 0=False in VBA. This really shouldn't be necessary however and your way is certainly easier to read.

Slow macro hiding rows based on value

I have a table that I want to completely hide or hide/show rows within the table, depending on whether a cell value is 0 or above.
It looks for a value of 0 within cell D26; if 0 it hides rows 24-51, if not 0 it hides/shows rows depending on whether there is a value in the C column between rows 34 and 49.
The macro below is too slow to be a viable option. Can anyone suggest an alternative way of doing this, that might work in a few seconds rather than a few minutes? I think it's because I'm running the For/If/Else loop.
Sub HideManifolds()
'
' HideManifolds Macro
'
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
ChkCol = 3
Manifold1BeginTableRow = 34
Manifold1EndTableRow = 49
Manifold1BeginRow = 24
Manifold1EndRow = 51
For Manifold1RowCnt = Manifold1BeginRow To Manifold1EndRow
If Cells(26, 4).Value = 0 Then
Cells(Manifold1RowCnt, 1).EntireRow.Hidden = True
Else
For Manifold1TableRowCnt = Manifold1BeginTableRow To Manifold1EndTableRow
If Cells(Manifold1TableRowCnt, ChkCol).Value = 0 Then
Cells(Manifold1TableRowCnt, ChkCol).EntireRow.Hidden = True
Else
Cells(Manifold1TableRowCnt, ChkCol).EntireRow.Hidden = False
End If
Next Manifold1TableRowCnt
End If
Next Manifold1RowCnt
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
'
End Sub

I think you don't need this loop For Manifold1RowCnt = Manifold1BeginRow To Manifold1EndRow
code:
Sub HideManifolds()
'
' HideManifolds Macro
'
Dim hRng As Range, vRng As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
ChkCol = 3
Manifold1BeginTableRow = 34
Manifold1EndTableRow = 49
Manifold1BeginRow = 24
Manifold1EndRow = 51
If Cells(26, 4).Value = 0 Then
Rows(Manifold1BeginRow & ":" & Manifold1EndRow).Hidden = True
Else
For Manifold1TableRowCnt = Manifold1BeginTableRow To Manifold1EndTableRow
If Cells(Manifold1TableRowCnt, ChkCol).Value = 0 Then
If hRng Is Nothing Then
Set hRng = Cells(Manifold1TableRowCnt, ChkCol)
Else
Set hRng = Union(hRng, Cells(Manifold1TableRowCnt, ChkCol))
End If
Else
If vRng Is Nothing Then
Set vRng = Cells(Manifold1TableRowCnt, ChkCol)
Else
Set vRng = Union(vRng, Cells(Manifold1TableRowCnt, ChkCol))
End If
End If
Next Manifold1TableRowCnt
If Not hRng Is Nothing Then hRng.EntireRow.Hidden = True
If Not vRng Is Nothing Then vRng.EntireRow.Hidden = False
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
'
End Sub

Repeating merged cell range

I have the following basic script that merges cells with the same value in Column R
Sub MergeCells()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim rngMerge As Range, cell As Range
Set rngMerge = Range("R1:R1000")
MergeAgain:
For Each cell In rngMerge
If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
Range(cell, cell.Offset(1, 0)).Merge
GoTo MergeAgain
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
What I would like to do is repeat this in columns A:Q and S:T but, I would like these columns to be merged in the same merged cell ranges as column R, i.e. if R2:R23 is merged then A2:A23, B2:B23, C2:C23 etc. will also be merge.
Columns A:Q do not contain values, column S:T have values but, these will be the same values throughout the range.
Any ideas

Apols for the earlier edit - this now deals with more than one duplicate in col R.
Note that this approach will work on the current (active) sheet.
Sub MergeCells()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim cval As Variant
Dim currcell As Range
Dim mergeRowStart As Long, mergeRowEnd As Long, mergeCol As Long
mergeRowStart = 1
mergeRowEnd = 1000
mergeCol = 18 'Col R
For c = mergeRowStart To mergeRowEnd
Set currcell = Cells(c, mergeCol)
If currcell.Value = currcell.Offset(1, 0).Value And IsEmpty(currcell) = False Then
cval = currcell.Value
strow = currcell.Row
endrow = strow + 1
Do While cval = currcell.Offset(endrow - strow, 0).Value And Not IsEmpty(currcell)
endrow = endrow + 1
c = c + 1
Loop
If endrow > strow+1 Then
Call mergeOtherCells(strow, endrow)
End If
End If
Next c
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub mergeOtherCells(strw, enrw)
'Cols A to T
For col = 1 To 20
Range(Cells(strw, col), Cells(enrw, col)).Merge
Next col
End Sub

You can try the below code as well. It would require you to put a 'No' after the last line in column R (R1001) so as to end the while loop.
Sub Macro1()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
flag = False
k = 1
While ActiveSheet.Cells(k, 18).Value <> "No"
i = 1
j = 0
While i < 1000
rowid = k
If Cells(rowid, 18).Value = Cells(rowid + i, 18).Value Then
j = j + 1
flag = True
Else
i = 1000
End If
i = i + 1
Wend
If flag = True Then
x = 1
While x < 21
Range(Cells(rowid, x), Cells(rowid + j, x)).Merge
x = x + 1
Wend
flag = False
k = k + j
End If
k = k + 1
Wend
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

VBA code not working for a large number of iterations

For some reason this macro freezes EXCEL when I set the for home = X to XX loop to more than 10 iterations.
This code downloads a webpage into excel, extracts cells that contain either 'overall' or 'carried' and copy them into another sheet in the same workbook.
Thank you
Sub Macro1()
'
' Macro1 Macro
'
'
Dim home As Integer
Dim Calc_sheet As Worksheet
Dim score_count As Integer
Dim inspection_count As Integer
Dim output_rows As Integer
Dim output_columns As Integer
Dim date_columns As Integer
'Counting variables
score_count = 3
inspection_count = 8
'Output rows and columns starting values
output_rows = 3
output_columns = 3
date_columns = 8
For home = 20 To 23
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://www.XXXXXXXX.org.uk/directory/" & Sheets("Output").Cells(home, 1), Destination:=Range("$A$1") _
)
'.CommandType = 0
.Name = "Homes"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
For x = 20 To 250
Select Case Left(Cells(x, 1), 7)
'Is it a score?
Case Is = "Overall"
Cells(x, 1).Copy
Sheets("Output").Select
Cells(output_rows, output_columns).Select
ActiveSheet.Paste
output_columns = output_columns + 1
'Is it a date?
Case Is = "Carried"
Cells(x, 1).Copy
Sheets("Output").Select
Cells(output_rows, date_columns).Select
ActiveSheet.Paste
date_columns = date_columns + 1
Case Else
End Select
Sheets("Calc_sheet").Activate
Cells(x, 1).Activate
Next x
'Clean sheet
ActiveSheet.Cells.Delete
'Go back to top
Range("A1").Select
'Reset column count
output_columns = 3
date_columns = 8
output_rows = output_rows + 1
Next home
End Sub

I updated the code, try it again!
Try replacing your inner-loop with this one :
Dim wsC As Worksheet
Dim wsO As Worksheet
Set wsC = Worksheets("Calc_sheet")
Set wsO = Worksheets("Output")
For x = 20 To 250
yourContent = wsC.Cells(x, 1)
yourCase = Left(yourContent, 7)
Select Case yourCase
'Is it a score?
Case Is = "Overall"
wsO.Cells(output_rows, output_columns) = yourContent
output_columns = output_columns + 1
'Is it a date?
Case Is = "Carried"
wsO.Cells(output_rows, date_columns) = yourContent
date_columns = date_columns + 1
Case Else
End Select
Next x