Slow Excel VBA code - excel

I have tried to write a code that will look at cells in B2 from Row 4 to R2000 and if the content is zero then hide the row. My problem is that the code is running very slow and often stops responding.
If you can help me what it is that is causing it to run slow, I can probably fix it myself, but I am not sure what would be a more efficient approach. As you can see I have tried with turning screen updates off, but it didn’t help much.
The code is below
Sub HideRows()
BeginRow = 4
EndRow = 2059
ChkCol = 2
Application.ScreenUpdating = False
Rows("1:2059").EntireRow.Hidden = False
For RowCnt = BeginRow To EndRow
If Cells(RowCnt, ChkCol).Value = 0 Then
Cells(RowCnt, ChkCol).EntireRow.Hidden = True
End If
Next RowCnt
Application.ScreenUpdating = True
End Sub

Try hiding everything in one go instead of every time a 0 is found
Sub HideRows()
Dim BeginRow As Long, EndRow As Long, ChkCol As Long
Dim HideRng As Range
BeginRow = 4
EndRow = 2059
ChkCol = 2
Application.ScreenUpdating = False
Rows("1:2059").EntireRow.Hidden = False
For rowcnt = BeginRow To EndRow
If Cells(rowcnt, ChkCol).Value2 = 0 Then
If HideRng Is Nothing Then
Set HideRng = Cells(rowcnt, ChkCol)
Else
HideRng = Union(HideRng, Cells(rowcnt, ChkCol))
End If
End If
Next rowcnt
If Not HideRng Is Nothing Then HideRng.EntireRow.Hidden = True
Application.ScreenUpdating = True
End Sub

Without seeing your workbook, it's hard to know for sure, but generally Excel is pretty slow at hiding rows. In your code, each row is hidden one at a time, so that's potentially 1000+ individual "hide this row" commands to Excel.
It's much faster to hide the rows in "chunks". This macro (I wrote it ages ago because I was dealing with the same problem) does that, so it should be much faster. In your case, you'd call it like this:
Call hideRows(ActiveSheet, 4, 2059, 0, 2, 2)
There's also an inverted setting that would hide rows unless the value in column 2 was equal to zero. You'd just add "True" to the end of your function call.
Sub hideRows(ws As Worksheet, startRow As Long, endRow As Long, valCrit As Variant, Optional startCol As Long = 1, Optional endCol As Long = 1, Optional invert As Boolean = False)
Dim loopCounter As Long
Dim rowCounter As Long
Dim colCounter As Long
Dim endConsRow As Long
Dim tempArr As Variant
Dim toAdd As Long
Dim toHide As String
Dim sameVal As Boolean
Dim consBool As Boolean
Dim tempBool As Boolean
Dim rowStr As String
Dim goAhead As Boolean
Dim i As Long
If startRow > endRow Then
toAdd = endRow - 1
Else
toAdd = startRow - 1
End If
tempArr = ws.Range(ws.Cells(startRow, startCol), ws.Cells(endRow, endCol)).Value
ws.Rows(startRow & ":" & endRow).Hidden = False
loopCounter = 1
For rowCounter = LBound(tempArr, 1) To UBound(tempArr, 1)
For colCounter = LBound(tempArr, 2) To UBound(tempArr, 2)
sameVal = False
goAhead = False
If IsNumeric(valCrit) Then
If tempArr(rowCounter, colCounter) = valCrit Then
sameVal = True
End If
Else
If tempArr(rowCounter, colCounter) Like valCrit Then
sameVal = True
End If
End If
If sameVal Then
If invert = True Then
loopCounter = loopCounter + 1
Exit For
End If
goAhead = True
ElseIf colCounter = UBound(tempArr, 2) Then
If invert = False Then
loopCounter = loopCounter + 1
Exit For
End If
goAhead = True
End If
If goAhead = True Then
endConsRow = rowCounter
consBool = True
Do Until consBool = False
tempBool = False
For i = LBound(tempArr, 2) To UBound(tempArr, 2)
sameVal = False
If endConsRow = UBound(tempArr, 1) Then
Exit For
ElseIf IsNumeric(valCrit) Then
If tempArr(endConsRow + 1, i) = valCrit Then
sameVal = True
End If
Else
If tempArr(endConsRow + 1, i) Like valCrit Then
sameVal = True
End If
End If
If sameVal Then
If invert = False Then
endConsRow = endConsRow + 1
tempBool = True
End If
Exit For
ElseIf i = UBound(tempArr, 2) Then
If invert = True Then
endConsRow = endConsRow + 1
tempBool = True
End If
End If
Next
If tempBool = False Then
consBool = False
End If
Loop
rowStr = loopCounter + toAdd & ":" & endConsRow + toAdd
If toHide = "" Then
toHide = rowStr
ElseIf Len(toHide & "," & rowStr) > 255 Then
ws.Range(toHide).EntireRow.Hidden = True
toHide = rowStr
Else
toHide = toHide & "," & rowStr
End If
loopCounter = loopCounter + 1 + (endConsRow - rowCounter)
rowCounter = endConsRow
Exit For
End If
Next
Next
If Not toHide = "" Then
ws.Range(toHide).EntireRow.Hidden = True
End If
End Sub

Can you use Autofilter?
Option Explicit
Public Sub HideRowsWhereColBis0()
ActiveSheet.Range("B4:B2059").AutoFilter Field:=1, Criteria1:="<>0"
End Sub

Related

Get only Sub names

Using below code I am getting both Sub names and functions name, but I want only Sub names excluding function names, please suggest me for this, it will be really helpful for me
Sub ListMacros()
Dim VBComp As VBComponent
Dim VBCodeMod As CodeModule
Dim oListsheet As Object
Dim StartLine As Long
Dim ProcName As String
Dim iCount As Integer
Application.ScreenUpdating = False
On Error Resume Next
Set oListsheet = ActiveWorkbook.Worksheets.Add
iCount = 1
oListsheet.[a1] = "Macro"
For Each VBComp In ThisWorkbook.VBProject.VBComponents
Set VBCodeMod = ThisWorkbook.VBProject.VBComponents(VBComp.Name).CodeModule
With VBCodeMod
StartLine = .CountOfDeclarationLines + 1
Do Until StartLine >= .CountOfLines
oListsheet.[a1].Offset(iCount, 0).Value = _
.ProcOfLine(StartLine, vbext_pk_Proc)
iCount = iCount + 1
StartLine = StartLine + _
.ProcCountLines(.ProcOfLine(StartLine, _
vbext_pk_Proc), vbext_pk_Proc)
Loop
End With
Set VBCodeMod = Nothing
Next VBComp
Application.ScreenUpdating = True
End Sub
Please add this lines:
If InStr(.Lines(StartLine, 2), "Function") = 0 Then
iCount = iCount + 1
End If
'2 lines because sometimes it returns "" for only a line (from unknown reasons)...
after
oListsheet.[a1].Offset(iCount, 0).Value = _
.ProcOfLine(StartLine, vbext_pk_Proc)
Edited, to return the standard module type, too:
If InStr(.Lines(StartLine, 2), "Function") = 0 Then
If VBComp.Type = 1 Then
oListsheet.[a1].Offset(iCount, 1).Value = VBComp.Name
End If
iCount = iCount + 1
End If
' *****************************************************************************************
' Connect to Siebel
' *****************************************************************************************
Function WriteCell(iRow As Integer, iCol As Integer, iColor As Integer, Msg As String)
ViewsSheet.Cells(iRow, iCol).Font.ColorIndex = iColor
ViewsSheet.Cells(iRow, iCol).Value = Msg
End Function
Sub ListMacros()
Application.DisplayAlerts = False
ActiveWorkbook.Save
Dim VBComp As VBComponent
Dim VBCodeMod As CodeModule
Dim oListsheet As Object
Dim StartLine As Long
Dim ProcName As String
Dim iCount As Integer
Application.ScreenUpdating = False
On Error Resume Next
Set oListsheet = ActiveWorkbook.Worksheets.Add
oListsheet.Name = "MacroList"
iCount = 0
oListsheet.[a1] = ""
For Each VBComp In ThisWorkbook.VBProject.VBComponents
Set VBCodeMod = ThisWorkbook.VBProject.VBComponents(VBComp.Name).CodeModule
With VBCodeMod
StartLine = .CountOfDeclarationLines + 1
Do Until StartLine >= .CountOfLines
oListsheet.[a1].Offset(iCount, 0).Value = .ProcOfLine(StartLine, vbext_pk_Proc)
'If InStr(.Lines(StartLine, 2), "Function") = 0 Then
iCount = iCount + 1
'End If
StartLine = StartLine + .ProcCountLines(.ProcOfLine(StartLine, vbext_pk_Proc), vbext_pk_Proc)
Loop
End With
Set VBCodeMod = Nothing
Next VBComp
Application.ScreenUpdating = True
Dim FilePath As String
Dim CellData As String
Dim LastCol As Long
Dim LastRow As Long
Dim i As Long
Dim j As Long
LastCol = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column
LastRow = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
CellData = ""
FilePath = "E:\Dir\Excel\MacroTxt\\MacroList2.txt"
Open FilePath For Output As #2
For i = 1 To LastRow
For j = 1 To LastCol
If j = LastCol Then
CellData = CellData + Trim(ActiveCell(i, j).Value)
Else
CellData = CellData + Trim(ActiveCell(i, j).Value) + ","
End If
Next j
Write #2, CellData
CellData = ""
Next i
Close #2
Application.DisplayAlerts = False
End Sub

How do I figure out if my temporary folder is overloading? (Apologies on the length)

I have a macro that threw the below error, and I have a theory why, but am having trouble finding any literature to back it up. Pages I found are typically people posting silly mistakes with incorrect variable types.
I don't think there's anything wrong with the code, I just think the nature of the task takes too long, therefore overloading the temp folder. Per TechWalla (emphasis mine):
The Runtime Error 6 occurs in the Visual Basic program. It is an overflow issue that can occur when the Visual Basic program attempts to store too much data in the temporary folders area. Runtime files help Windows translate a program's language into Windows language so the program runs faster. You can get the Runtime Error 6 message for several reasons. One reason is that you are using a backslash instead of a forward slash in one of your calculations. Other reasons include an overloaded temporary folder, outdated software or a registry error.
(Caveat: I haven't seen this explanation elsewhere and can't vouch for how reliable Techwalla is. I don't know if I'm not searching with the right keywords, but like I said, I haven't found much of anything other than code-specific forum posts.)
Is there a way to determine if this is the case? I outline below why I think this is what's causing the error, which might help, but doesn't change the question. If this is the case, is there a way to find out? And if so, is there a way to prevent it?
(I'll be running it again tonight now that I've used a registry cleaner that found 1GB, though I don't know how much was from Excel. For reference, my C: drive has 180GB free...)
EDIT: Removing code, because I'm asking not asking about that, but whether or not the temporary folder overloading could actually cause this.
EDIT2: After being swayed by the people, I am re-adding the code. And I know, it's not efficient. Thank you for the suggestions though.
EDIT3 (LAST ONE, I SWEAR): Though I realize the description above specifically mentions Visual Basic, which is not VBA, I'm keeping it in as I know Excel uses/creates temporary files, and has memory limits, which is ultimately what I'm curious about.
Sub getCBU()
Dim rowCount As Long, newRow(1 To 17) As Variant, compareRow(1 To 17) As Variant, nextFile As String, s As Long
Dim location As String, lastRow As Long, match As Boolean, startTime As Double, secondsElapsed As String
location = "C:\Users\swallin\Documents\CBU History\"
nextFile = Dir(location & "CBU*")
rowCount = 2
startTime = Timer
Do While nextFile <> ""
Workbooks.Open (location & nextFile)
lastRow = Workbooks(nextFile).Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
For s = 18 To lastRow
match = True
For x = 1 To 17
newRow(x) = Workbooks(nextFile).Worksheets(1).Cells(s, x)
Next x
For y = 2 To rowCount
If Val(newRow(11)) = Val(ThisWorkbook.Worksheets(1).Cells(y, 11)) Then
For j = 1 To 17
compareRow(j) = ThisWorkbook.Worksheets(1).Cells(y, j).Value
Next j
For v = 1 To 17
If Val(compareRow(v)) <> Val(newRow(v)) Then
match = False
Exit For
Else
match = True
End If
Next v
If match = True Then
Exit For
End If
Else
match = False
End If
Next y
y = 2
If match = False Then
rowCount = rowCount + 1
For t = 1 To 17
ThisWorkbook.Worksheets(1).Cells(rowCount, t) = newRow(t)
Next t
End If
Next s
s = 18
Workbooks(nextFile).Close
nextFile = Dir()
Loop
secondsElapsed = Format((Timer - startTime) / 86400, "hh:mm:ss")
ThisWorkbook.Worksheets(2).Cells(1, 1) = secondsElapsed
End Sub
This opens a new instance for each file and closes it afterwards. Give it a try (I could not test it). This includes all the suggestions I made in the chat.
Option Explicit
Sub getCBU()
Dim location As String
location = "C:\Users\swallin\Documents\CBU History\"
Dim nextFile As String
nextFile = Dir(location & "CBU*")
Dim rowCount As Long
rowCount = 2
Dim startTime As Double
startTime = Timer
Dim newRow(1 To 17) As Variant, compareRow(1 To 17) As Variant
Dim lastRow As Long, match As Boolean
Dim s As Long, x As Long, y As Long, j As Long, v As Long, t As Long
Dim objExcel As Object, ActWb As Workbook
Do While nextFile <> ""
Set objExcel = CreateObject("Excel.Application") 'new excel instance
Set ActWb = objExcel.Workbooks.Open(Filename:=location & nextFile, ReadOnly:=True)
lastRow = ActWb.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
For s = 18 To lastRow
match = True
For x = 1 To 17
newRow(x) = ActWb.Worksheets(1).Cells(s, x)
Next x
For y = 2 To rowCount
If Val(newRow(11)) = Val(ThisWorkbook.Worksheets(1).Cells(y, 11)) Then
For j = 1 To 17
compareRow(j) = ThisWorkbook.Worksheets(1).Cells(y, j).Value
Next j
For v = 1 To 17
If Val(compareRow(v)) <> Val(newRow(v)) Then
match = False
Exit For
Else
match = True
End If
Next v
If match = True Then
Exit For
End If
Else
match = False
End If
Next y
y = 2
If match = False Then
rowCount = rowCount + 1
For t = 1 To 17
ThisWorkbook.Worksheets(1).Cells(rowCount, t) = newRow(t)
Next t
End If
Next s
s = 18
ActWb.Close SaveChanges:=False
objExcel.Quit 'close excel instance
Set objExcel = Nothing 'free variable
nextFile = Dir()
Loop
Dim secondsElapsed As String
secondsElapsed = Format$((Timer - startTime) / 86400, "hh:mm:ss")
ThisWorkbook.Worksheets(2).Cells(1, 1) = secondsElapsed
End Sub
Not sure about the writing back to the sheet part (i would still allocate the values to an array and write it back all together, but that depends on what you have in the sheet already, plus whatever newRow() does), but can you give this a try and see if there is any improvement in speed?
Sub getCBU()
Dim rowCount As Long, newRow(1 To 17) As Variant, compareRow(1 To 17) As Variant, nextFile As String
Dim location As String, lastRow As Long, match As Boolean, startTime As Double, secondsElapsed As String
Dim arrData, arrOutput()
Dim arrTemp(): ReDim arrOutput(1 To 17, 1 To 1)
Dim R As Long, C As Long
location = "C:\Users\swallin\Documents\CBU History\"
nextFile = Dir(location & "CBU*")
rowCount = 2
startTime = Timer
Do While nextFile <> ""
Workbooks.Open (location & nextFile)
lastRow = Workbooks(nextFile).Worksheets(1).Cells(Rows.Count, 1).End(xlUp).row
With Workbooks(nextFile).Worksheets(1)
arrData = .Range(.Cells(1, 1), .Cells(lastRow, 17))
End With
For s = 18 To lastRow
match = True
For X = 1 To 17
newRow(X) = arrData(s, X)
Next X
For y = 2 To rowCount
If Val(newRow(11)) = Val(arrData(y, 11)) Then
For j = 1 To 17
compareRow(j) = arrData(y, j).Value
Next j
For v = 1 To 17
If Val(compareRow(v)) <> Val(newRow(v)) Then
match = False
Exit For
Else
match = True
End If
Next v
If match = True Then
Exit For
End If
Else
match = False
End If
Next y
y = 2
If match = False Then
rowCount = rowCount + 1
ReDim Preserve arrTemp(1 To 17, 1 To rowCount)
For t = 1 To 17
arrTemp(t, rowCount) = newRow(t)
Next t
End If
Next s
s = 18
Workbooks(nextFile).Close
nextFile = Dir()
Loop
'Transpose the array
ReDim arrOutput(1 To UBound(arrTemp, 2), 1 To UBound(arrTemp))
For C = LBound(arrTemp) To UBound(arrTemp)
For R = LBound(arrTemp, 2) To UBound(arrTemp, 2)
arrOutput(R, C) = arrTemp(C, R)
Next R
Next C
'Allocate back to the spreadsheet
With ThisWorkbook.Worksheets(1)
.Range(.Cells(2, 1), .Cells(UBound(arrOutput) + 1, 17)) = arrOutput
End With
secondsElapsed = Format((Timer - startTime) / 86400, "hh:mm:ss")
ThisWorkbook.Worksheets(2).Cells(1, 1) = secondsElapsed
End Sub
PS: As others suggested, is a good idea to use Option Explicit, and eventually to step through to code and see if everything is working as intended.
As for the Overflow issue... stepping through code would/should resolve that as well eventually. See Overflow (Error 6) for more info.
EDIT: I've added further management to holding the values in an array, and writing back to the spreadsheet.
Here's a revamp of your code that should be quicker and more memory friendly. (updated to be able to handle any number of results).
Sub getCBU()
Dim wb As Workbook
Dim wsDest As Worksheet
Dim wsTime As Worksheet
Dim hUnqVals As Object
Dim hUnqRows As Object
Dim aHeaders() As Variant
Dim aCompare() As Variant
Dim aResults() As Variant
Dim aStartingData() As Variant
Dim sFolder As String
Dim sFile As String
Dim sDelim As String
Dim sTemp As String
Dim lMaxResults As Long
Dim lCompareStartRow As Long
Dim lValCompareCol As Long
Dim ixCompare As Long
Dim ixResult As Long
Dim ixCol As Long
Dim dTimer As Double
dTimer = Timer
Set wb = ThisWorkbook
Set wsDest = wb.Worksheets(1)
Set wsTime = wb.Worksheets(2)
Set hUnqRows = CreateObject("Scripting.Dictionary")
Set hUnqVals = CreateObject("Scripting.Dictionary")
sDelim = "|"
lMaxResults = 100000
lCompareStartRow = 18
lValCompareCol = 11
sFolder = Environ("UserProfile") & "\Documents\CBU History\" 'Be sure to including ending \
sFile = Dir(sFolder & "CBU*.xlsx")
With wsDest.Range("A2:Q" & wsDest.Cells(wsDest.Rows.Count, lValCompareCol).End(xlUp).Row)
If .Row > 1 Then
aHeaders = .Offset(-1).Resize(1).Value
aStartingData = .Value
ReDim aResults(1 To lMaxResults, 1 To .Columns.Count)
For ixResult = 1 To UBound(aStartingData, 1)
For ixCol = 1 To UBound(aStartingData, 2)
sTemp = sTemp & sDelim & aStartingData(ixResult, ixCol)
Next ixCol
If Not hUnqRows.Exists(sTemp) Then hUnqRows.Add sTemp, sTemp
If Not hUnqVals.Exists(aStartingData(ixResult, lValCompareCol)) Then hUnqVals.Add aStartingData(ixResult, lValCompareCol), aStartingData(ixResult, lValCompareCol)
sTemp = vbNullString
Next ixResult
Erase aStartingData
Else
'No data to compare against, so no data can be added, exit macro
MsgBox "No data found in [" & wsDest.Name & "]" & Chr(10) & "Exiting Macro.", , "Error"
Exit Sub
End If
End With
With Application
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
ixResult = 0
Do While Len(sFile) > 0
Application.StatusBar = "Processing " & sFile & "..."
With Workbooks.Open(sFolder & sFile, , True).Worksheets(1)
With .Range("A" & lCompareStartRow & ":Q" & .Cells(.Rows.Count, lValCompareCol).End(xlUp).Row)
If .Row >= lCompareStartRow Then
aCompare = .Value
For ixCompare = 1 To UBound(aCompare, 1)
If hUnqVals.Exists(aCompare(ixCompare, lValCompareCol)) Then
For ixCol = 1 To UBound(aCompare, 2)
sTemp = sTemp & sDelim & aCompare(ixCompare, ixCol)
Next ixCol
If Not hUnqRows.Exists(sTemp) Then
hUnqRows.Add sTemp, sTemp
ixResult = ixResult + 1
For ixCol = 1 To UBound(aCompare, 2)
aResults(ixResult, ixCol) = aCompare(ixCompare, ixCol)
Next ixCol
If ixResult = lMaxResults Then OutputResults wsDest, aResults, ixResult, aHeaders
End If
sTemp = vbNullString
End If
Next ixCompare
Erase aCompare
End If
End With
.Parent.Close False
End With
sFile = Dir()
Loop
Application.StatusBar = vbNullString
If ixResult > 0 Then OutputResults wsDest, aResults, ixResult, aHeaders
wsTime.Range("A1").Value = Format((Timer - dTimer) / 86400, "hh:mm:ss")
With Application
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Sub OutputResults(ByRef arg_ws As Worksheet, ByRef arg_aResults As Variant, ByRef arg_ixResult As Long, ByVal arg_aHeaders As Variant)
Static wsDest As Worksheet
Dim rDest As Range
Dim lMaxRows As Long
Dim lMaxCols As Long
If wsDest Is Nothing Then Set wsDest = arg_ws
lMaxRows = UBound(arg_aResults, 1)
lMaxCols = UBound(arg_aResults, 2)
Set rDest = wsDest.Range("A1").Resize(, lMaxCols).EntireColumn.Find("*", wsDest.Range("A1"), xlValues, xlWhole, , xlPrevious)
If rDest Is Nothing Then Set rDest = wsDest.Range("A2") Else Set rDest = wsDest.Cells(rDest.Row, "A")
If rDest.Row + 1 + arg_ixResult > wsDest.Rows.Count Then
Set wsDest = wsDest.Parent.Worksheets.Add(After:=wsDest)
With wsDest.Range("A1").Resize(, lMaxCols)
.Value = arg_aHeaders
.Font.Bold = True
End With
Set rDest = wsDest.Range("A2")
End If
rDest.Resize(arg_ixResult, lMaxCols).Value = arg_aResults
Erase arg_aResults
ReDim arg_aResults(1 To lMaxRows, 1 To lMaxCols)
End Sub

How to fix the error in the excel vba code?

I want to have alternate backgrd colour for different text
I wrote a code for it and there are several errors. How can I improve it? Thanks
Sub Alternatecolour()
Flag = True
lr = Cells(Rows.Count, 1).End(xlUp).Row
Startcl = Cells(2, "D")
For Each cl In Range("D2:D" & lr)
str1 = cl.Text
str2 = cl.Offset(-1, 0).Text
Diff = StrComp(str1, str2, vbBinaryCompare)
If Diff = 0 Then
GoTo Loopend
End If
If Diff <> 0 Then
If Flag = True Then
Range(Startcl, cl).Interior.Color = 15
Startcl = cl
Flag = False
Else
Range(Startcl, cl).Interior.Color = 16
Startcl = cl
Flag = True
End If
End If
Loopend
Next cl
End Sub
I suggest the following code:
Public Sub AlternateColor()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("ColorMe")
Dim ColorRange As Range
Set ColorRange = ws.Range("D2", ws.Cells(ws.Rows.Count, "D").End(xlUp))
Dim StartRow As Long
StartRow = ColorRange.Row
Dim ActColor As Long
ActColor = 15
Dim iRow As Long
For iRow = ColorRange.Row To ColorRange.Rows.Count + ColorRange.Row - 1
If ws.Cells(iRow, "D").Value <> ws.Cells(iRow, "D").Offset(1, 0).Value Then
ws.Range(ws.Cells(StartRow, "D"), ws.Cells(iRow, "D")).Interior.ColorIndex = ActColor
ActColor = IIf(ActColor = 15, 16, 15)
StartRow = iRow + 1
End If
Next iRow
End Sub

Loop through arrays with multiple columns and rows

I've done a lot of searching to try and optimize this code. I've reduced the run time down significantly, but I can't seem to find anything else (note: I've done all the xlcalculationmanual and screenupdating = false jazz)
Here is the basic structure of my current loop. The matrix is currently 5 rows down with data to loop through and 9 across.
Application.Calculation = xlCalculationManual
i = 0
Do While wsc1.Cells(10, i + 65) <> "things" And wsc1.Cells(10, i + 65) <> "thing2" And wsc1.Cells(10, i + 65) <> ""
j = 0
Do While wsc1.Cells(j + 11, 64) <> ""
wsc.Cells(109, 3) = wsc1.Cells(j + 11, 64) 'rows
wsc.Cells(109, 6) = wsc1.Cells(10, i + 65) 'columns
Application.Calculation = xlCalculationAutomatic
Application.Calculation = xlCalculationManual
wsc1.Cells(j + 11, i + 65) = wsc.Range("O6") 'Print
j = j + 1
Loop
i = i + 1
Loop
I assume my next best option is storing the column/row vector as a variant and looping through that?
Thanks
Can you also add these lines?
Application.EnableEvents = False
Application.ScreenUpdating = False ' it seems that you already have this one?
Give this a try. However, having to wait for the sheet calculation is a pretty hard slowdown, there's really not much that can be done beyond this to improve performance if we can't put the calculations in the code.
Sub tgr()
Dim wsc1 As Worksheet
Dim CValues As Variant
Dim FValues As Variant
Dim Results() As Variant
Dim i As Long, j As Long
Dim xlCalc As XlCalculation
With Application
xlCalc = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
On Error GoTo CleanExit
Set wsc1 = ActiveWorkbook.ActiveSheet
With wsc1.Range("BL11", wsc1.Cells(wsc1.Rows.Count, "BL").End(xlUp))
If .Row < 11 Then Exit Sub 'No data
If .Cells.Count = 1 Then
ReDim CValues(1 To 1, 1 To 1)
CValues(1, 1) = .Value
Else
CValues = .Value
End If
End With
With wsc1.Range("BM10", wsc1.Cells(10, wsc1.Columns.Count).End(xlToLeft))
If .Column < Columns("BM").Column Then Exit Sub 'No data
If .Cells.Count = 1 Then
ReDim FValues(1 To 1, 1 To 1)
FValues(1, 1) = .Value
Else
FValues = .Value
End If
End With
ReDim Results(1 To UBound(CValues, 1), 1 To UBound(FValues, 2))
For i = LBound(CValues, 1) To UBound(CValues, 1)
For j = LBound(FValues, 2) To UBound(FValues, 2)
wsc1.Range("C109").Value = CValues(i, 1)
wsc1.Range("F109").Value = FValues(1, j)
wsc1.Calculate
Results(i, j) = wsc1.Range("O6").Value
Next j
Next i
wsc1.Range("BM11").Resize(UBound(Results, 1), UBound(Results, 2)).Value = Results
CleanExit:
With Application
.Calculation = xlCalc
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

Count specific value in a cell from source and split the cells of target file according to that count value using macro [duplicate]

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

Resources