Adding 1 to each row without using for loop in VBA - excel

Looking for an easy way to add a certain number to each row in a column. Something like range("b1:b9")=range("a1:a9")+1
From this:
to this:

You could use Evaluate, seems quite quick.
Sub Add1()
With Range("A1:A10000")
.Value = Evaluate(.Address & "+1")
End With
End Sub

Looking for a "time-efficient" solution and avoiding loops are not the same thing.
If you were to loop over the range itself, then yes, it would be slow. Copying the range data to a Variant array, looping that, then copying the result back to the range is fast.
Here is a demo
Sub Demo()
Dim rng As Range
Dim dat As Variant
Dim i As Long
Dim t1 As Single
t1 = Timer() ' just for reportingh the run time
' Get a reference to your range by whatever means you choose.
' Here I'm specifying 1,000,000 rows as a demo
Set rng = Range("A1:A1000000")
dat = rng.Value2
For i = 1 To UBound(dat, 1)
dat(i, 1) = dat(i, 1) + 1
Next
rng.Value2 = dat
Debug.Print "Added 1 to " & UBound(dat, 1) & " rows in " & Timer() - t1; " seconds"
End Sub
On my hardware, this runs in about 1.3 seconds
FYI, the PasteSpecial, Add technique is faster still

Start the macro recorder.
type a 1 into an empty cell
copy that cell
select the cells that you want to add that value to
open the Paste Special dialog
select "Add" and OK
Stop the macro recorder. Use that code as is or work it into your other code.
Range("C1").Value = 1
Range("C1").Select
Application.CutCopyMode = False
Selection.Copy
Range("A1:A5").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlAdd, SkipBlanks:= False, Transpose:=False

Increase Range Values
In the following examples, the Add solution took 2.4s while the Array solution took 8.7s (on my machine) to process 5 columns.
In the Array solution, the selection is never changed, it just writes the result to the range.
The Add solution is kind of mimicking this behavior, by setting all selections as they initially were. Hence the complications.
Option Explicit
' Add Solution
Sub increaseRangeValuesTEST()
increaseRangeValues Sheet1.Range("A:E"), 1 ' 2.4s
End Sub
Sub increaseRangeValues( _
ByVal rg As Range, _
ByVal Addend As Double)
Application.ScreenUpdating = False
Dim isNotAW As Boolean: isNotAW = Not rg.Worksheet.Parent Is ActiveWorkbook
Dim iwb As Workbook
If isNotAW Then Set iwb = ActiveWorkbook: rg.Worksheet.Parent.Activate
Dim isNotAS As Boolean: isNotAS = Not rg.Worksheet Is ActiveSheet
Dim iws As Worksheet
If isNotAS Then Set iws = ActiveSheet: rg.Worksheet.Activate
Dim cSel As Variant: Set cSel = Selection
Dim aCell As Range: Set aCell = ActiveCell
Dim sCell As Range: Set sCell = rg.Cells(rg.Rows.Count, rg.Columns.Count)
Dim sValue As Double: sValue = sCell.Value + Addend
sCell.Value = Addend
sCell.Copy
rg.PasteSpecial xlPasteAll, xlPasteSpecialOperationAdd ' 95%
Application.CutCopyMode = False
sCell.Value = sValue
aCell.Activate
cSel.Select
If isNotAS Then iws.Activate
If isNotAW Then iwb.Activate
Application.ScreenUpdating = True
End Sub
' Array Solution
Sub increaseRangeValuesArrayTEST()
increaseRangeValuesArray Sheet1.Range("A:E"), 1 ' 8.7s
End Sub
Sub increaseRangeValuesArray( _
ByVal rg As Range, _
ByVal Addend As Double)
With rg
Dim rCount As Long: rCount = .Rows.Count
Dim cCount As Long: cCount = .Columns.Count
Dim Data As Variant
If rCount > 1 Or cCount > 1 Then
Data = .Value
Else
ReDim Data(1 To 1, 1 To 1): Data = .Value
End If
Dim r As Long, c As Long
For r = 1 To rCount
For c = 1 To cCount
Data(r, c) = Data(r, c) + Addend
Next c
Next r
.Value = Data ' 80%
End With
End Sub

#1. Disable your autocalculations
Application.Calculation = xlCalculationManual
#2. Disable your screenupdating
Application.ScreenUpdating = False
#3. As long as your row entries aren't more than ~56000, but your dataset is substantial then its quicker to read into an array, do the manipulations in an array, then output that array in one go.
array1 = Range(cells(3,2), cells(12,2)).value
for i = 1 to ubound(array1, 1)
array1(i, 1) = array(i, 1) + 1
next i
range(cells(3,10), cells(12,10)) = array1
Note that array1 will be 2D, and you'll be addressing (1,1) through to (10,1) in the example above
Then after pasting back in, reenable your autocalcs, THEN your screenupdate
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

Related

VBA: faster way to change row (or cell) color based on values without referring to cell

Is there in VBA faster way to change row (or cell) color based on values without referring to cell
Referring to cell each time inside loop is very slow, that's why i am looking for faster method doing it in VBA.
Table:
Amount1
Amount2
100
50
20
200
...
...
If Amount1 is greater than Amount2, entire row(or cell) is red, vice versa entire row(or cell) is green.
Thank You!
It would have been helpful if you had clarified why you can't use CF as suggested, but if you really can't when looping it's best to refer to directly to cells as little as possible, especially changing values or formats. Try something like this:
Sub SampleValues()
Dim bGreater As Boolean
Dim rng As Range, rRow As Range
Set rng = ActiveSheet.Range("A1:B1000")
rng.Formula = "=RANDBETWEEN(1,1000)"
rng.Value = rng.Value
End Sub
Sub RedOrGreen()
Dim clr As Long, i as long
Dim rng As Range, rRow As Range
Dim arr As Variant
Const clrMore = vbGreen, clrLessEqual = vbRed
Dim t As Single
t = Timer
Set rng = Range("A1:B1000")
arr = rng.Value
For Each rRow In rng.Rows
i = i + 1
If arr(i, 2) > arr(i, 1) Then
clr = clrMore
Else
clr = clrLessEqual
End If
If rRow.Interior.Color <> clr Then
rRow.Interior.Color = clr
End If
Next
Debug.Print Timer - t
End Sub
Highlight Rows
Sub HighlightRows()
Dim t As Double: t = Timer
' Define constants (adjust).
Const PROC_TITLE As String = "Highlight Rows"
Const SMALL_COL As Long = 1
Const GREAT_COL As Long = 2
Dim RowColors(): RowColors = VBA.Array(vbGreen, vbRed)
' Reference the table range.
' Turn off screen updating.
Application.ScreenUpdating = False
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
If ws.AutoFilterMode Then ws.AutoFilterMode = False
Dim trg As Range: Set trg = ws.Range("A1").CurrentRegion
' Validate rows and columns.
' Validate rows.
Dim rCount As Long: rCount = trg.Rows.Count
If rCount < 2 Then
MsgBox "No data or just headers in the range '" _
& trg.Address(0, 0) & "'.", vbCritical, PROC_TITLE
Exit Sub ' screen updating will automatically get turned on
End If
' Validate columns.
Dim cCount As Long: cCount = trg.Columns.Count
Dim MaxCol As Long: MaxCol = Application.Max(SMALL_COL, GREAT_COL)
If cCount < GREAT_COL Then
MsgBox "Column " & MaxCol & " is greater than the number " _
& "of columns (" & cCount & ") in the range ('" _
& trg.Address(0, 0) & "').", vbCritical, PROC_TITLE
Exit Sub ' screen updating will automatically get turned on
End If
' Reference and populate the helper columns.
' Insert two helper columns adjacent to the right of the table range.
trg.Offset(, cCount).Resize(, 2).Insert xlShiftToRight
' Remove this line if there is no data to the right.
' Reference the expanded table range (including the helper columns)...
Dim erg As Range: Set erg = trg.Resize(, cCount + 2) ' has headers
' ... and reference its data to be used with 'SpecialCells'.
Dim edrg As Range: Set edrg = erg.Resize(rCount - 1).Offset(1) ' no headers
' Reference the helper columns.
Dim CompareCol As Long: CompareCol = cCount + 1 ' for the auto filter
Dim crg As Range: Set crg = erg.Columns(CompareCol)
Dim irg As Range: Set irg = erg.Columns(cCount + 2)
' Write an ascending integer sequence to the Integer column.
irg.Value = ws.Evaluate("ROW(1:" & rCount & ")")
' Write the values from the criteria columns to arrays.
Dim SmallData(): SmallData = erg.Columns(SMALL_COL).Value
Dim GreatData(): GreatData = erg.Columns(GREAT_COL).Value
' Define the Compare array.
Dim CompareData(): ReDim CompareData(1 To rCount, 1 To 1)
Dim SmallVal, GreatVal, r As Long
' Write the Compare results to the Compare array
' (1 for the 1st color and 2 for the 2nd), ...
For r = 2 To rCount ' skip headers
SmallVal = SmallData(r, 1)
GreatVal = GreatData(r, 1)
If IsNumeric(SmallVal) And IsNumeric(GreatVal) Then
Select Case SmallVal
Case Is < GreatVal: CompareData(r, 1) = 1
Case Is > GreatVal: CompareData(r, 1) = 2
End Select
End If
Next r
Erase SmallData
Erase GreatData
' ... write the results from the array to the Compare column...
crg.Value = CompareData
Erase CompareData
' ... and sort the range by it.
erg.Sort crg, xlAscending, , , , , , xlYes
' Highlight the rows.
edrg.Interior.Color = xlNone ' clear previous colors
Dim vedrg As Range
For r = 1 To 2
erg.AutoFilter CompareCol, CStr(r)
On Error Resume Next ' prevent error when no filtered rows
Set vedrg = edrg.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
ws.AutoFilterMode = False ' turn off the auto filter!!!
If Not vedrg Is Nothing Then
Debug.Print vedrg.Address ' only two areas are being highlighted
vedrg.Interior.Color = RowColors(r - 1) ' 'RowColors' is zero-based
Set vedrg = Nothing ' reset for the next iteration
End If
Next r
' Clean up.
' Sort the range by the Integer column restoring initial order.
erg.Sort irg, xlAscending, , , , , , xlYes
' Delete the helper columns.
crg.Resize(, 2).Delete xlShiftToLeft
' If you have removed the Insert-line, replace this line with:
'crg.Resize(, 2).Clear
' Turn on screen updating to immediately see the changes
' (if the worksheet is active) before OK-ing the message box.
Application.ScreenUpdating = True
Debug.Print Format(Timer - t, "00.000000")
' Inform.
MsgBox "Rows highlighted.", vbInformation, PROC_TITLE
End Sub

Excel VBA Hidding rows by comparing two Cells

I have a question about how to use a double loop to compare two Cells which are located in different sheets("Sheet1" and "Sheet2").
The condition I want to apply to the Loop is that in case if the two cells are different, the row must be hidden (Applied to the table located in Sheet1). In the contrary case, if the two cells are the same, the row stays as it is by default.
But with the Macro I wrote, it hides all rows that form the Sheet1 table. What could be the reason?
Sub HideRows()
Sheets("Sheet2").Select
Dim NR As Integer
NR = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlDown)))
Sheets("Sheet1").Select
Dim i As Integer, j As Integer
For i = 2 To 10
For j = 1 To NR
If Cells(i, 1) <> Sheets("Sheet2").Cells(j, 1) Then
Rows(i & ":" & i).Select
Selection.EntireRow.Hidden = True
End If
Next j
Next I
End Sub
Sheet1:
Sheet2:
Desired result:
Your task is better described as
Hide all rows on Sheet1 whose column A value does not apear on Sheet2 column A
Using the looping the ranges technique you tried, this could be written as
Sub HideRows()
Dim rng1 As Range, cl1 As Range
Dim rng2 As Range, cl2 As Range
Dim HideRow As Boolean
With ThisWorkbook.Worksheets("Sheet1")
Set rng1 = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
With ThisWorkbook.Worksheets("Sheet2")
Set rng2 = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
rng1.EntireRow.Hidden = False
For Each cl1 In rng1.Cells
HideRow = True
For Each cl2 In rng2.Cells
If cl1.Value2 = cl2.Value2 Then
HideRow = False
Exit For
End If
Next
If HideRow Then
cl1.EntireRow.Hidden = True
End If
Next
End Sub
That said, while this approach is ok for small data sets, it will be slow for larger data sets.
A better approach is to loop Variant Arrays of the data, and build a range reference to allow hiding all required rows in one go
Sub HideRows2()
Dim rng1 As Range, cl1 As Range, dat1 As Variant
Dim rng2 As Range, cl2 As Range, dat2 As Variant
Dim HideRow As Boolean
Dim r1 As Long, r2 As Long
Dim HideRange As Range
With ThisWorkbook.Worksheets("Sheet1")
Set rng1 = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
dat1 = rng1.Value2
End With
With ThisWorkbook.Worksheets("Sheet2")
Set rng2 = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
dat2 = rng2.Value2
End With
rng1.EntireRow.Hidden = False
For r1 = 2 To UBound(dat1, 1)
HideRow = True
For r2 = 1 To UBound(dat2, 1)
If dat1(r1, 1) = dat2(r2, 1) Then
HideRow = False
Exit For
End If
Next
If HideRow Then
If HideRange Is Nothing Then
Set HideRange = rng1.Cells(r1, 1)
Else
Set HideRange = Application.Union(HideRange, rng1.Cells(r1, 1))
End If
End If
Next
If Not HideRange Is Nothing Then
HideRange.EntireRow.Hidden = True
End If
End Sub
#Chjris Neilsen has beaten me to most of what I wanted to mention. Please refer to his comment above. However, there are two things I want to add.
Please don't Select anything. VBA knows where everything is in your workbook. You don't need to touch. Just point.
i and j aren't really meaningful variable identifiers for Rows and Columns. They just make your task that much more difficult - as if you weren't struggling with the matter without the such extra hurdles.
With that out of the way, your code would look as shown below. The only real difference is the Exit For which ends the loop when the decision is made to hide a row. No guarantee that the procedure will now do what you want but the logic is laid are and shouldn't be hard to adjust. I point to .Rows(C).Hidden = True in this regard. C is not a row. It's a column.
Sub HideRows()
' always prefer Long datatype for rows and columns
Dim Rl As Long ' last row: Sheet2
Dim C As Long ' loop counter: columns
Dim R As Long ' loop counter: rows
Rl = WorksheetFunction.CountA(Sheet2.Columns(1))
With Sheet1
For C = 2 To 10
For R = 1 To Rl
' always list the variable item first
If Sheets("Sheet2").Cells(R, 1).Value <> .Cells(C, 1).Value Then
.Rows(C).Hidden = True
Exit For
End If
Next R
Next C
End With
End Sub

How to increment by 1 a loop in Visual Basic for Application

My first question on Stackoverflow, and a newbe, so please bare with me.
I am trying to sort out an excel sheet with 411,278 rows, about stock market data.
My code is as follows:
Sub Macro1()
'
' Macro1 Macro
'
Range("C6:C1577").Select
Selection.Copy
Range("D5").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("B6:C1577").Select
Range("C6").Activate
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
End Sub
I am trying to insert the above code in a loop that will increment all the numbers within the loop by 1.
For example (the next phase in the loop will be):
Sub Macro1()
'
' Macro1 Macro
'
Range("C7:C1578").Select
Selection.Copy
Range("D6").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("B7:C1578").Select
Range("C7").Activate
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
End Sub
Thanks!
A Data Transpose
The following will copy only the values (no formatting or formulas).
Adjust the values in the constants section. Note that you can choose a different worksheet for the result to leave your source data intact.
The Code
Option Explicit
Sub transposeValues()
' Define constants.
Const srcName As String = "Sheet1"
Const srcColumns As String = "B:D"
Const srcFirstRow As Long = 5
Const dstName As String = "Sheet1"
Const dstFirstCell As String = "B5"
Const dCount As Long = 1573
' Define workbook.
Dim wb As Workbook: Set wb = ThisWorkbook
' Define Source Range.
Dim rng As Range
With wb.Worksheets(srcName).Columns(srcColumns)
Set rng = .Resize(.Worksheet.Rows.Count - srcFirstRow + 1) _
.Offset(srcFirstRow - 1).Find( _
What:="*", _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious)
If rng Is Nothing Then
Exit Sub
End If
Set rng = .Resize(rng.Row - srcFirstRow + 1).Offset(srcFirstRow - 1)
End With
' Write values from Source Range to Data Array.
Dim Data As Variant: Data = rng.Value
' Define Result Array.
Dim srCount As Long: srCount = UBound(Data)
Dim Remainder As Long: Remainder = srCount Mod dCount
Dim drCount As Long
If Remainder = 0 Then
drCount = srCount / dCount
Else
drCount = Int(srCount / dCount) + 1
End If
Dim dcCount As Long: dcCount = dCount + 1
Dim Result As Variant: ReDim Result(1 To drCount, 1 To dcCount)
' Declare counters.
Dim i As Long, j As Long, k As Long
' Write values from Data Array to Result Array.
If drCount = 1 And Remainder > 0 Then
i = 1
Else
For i = 1 To drCount + (Remainder <> 0) * 1 ' In VBA 'True = -1'.
k = k + 1
For j = 1 To 2
Result(i, j) = Data(k, j)
Next j
For j = 3 To dcCount
k = k + 1
Result(i, j) = Data(k, 2)
Next j
Next i
End If
' Write the remainder of values in Data Array to Result Array.
If Remainder > 0 Then
k = k + 1
For j = 1 To 2
Result(i, j) = Data(k, j)
Next j
If Remainder > 1 Then
For j = 3 To 1 + Remainder
k = k + 1
Result(i, j) = Data(k, 2)
Next j
End If
End If
' Write values from Result Array to Destination Range.
With wb.Worksheets(dstName).Range(dstFirstCell).Resize(, dcCount)
.Resize(.Worksheet.Rows.Count - .Row + 1).ClearContents
.Resize(drCount).Value = Result
End With
End Sub
Please do not try this code without taking precautions.
Sub Macro1()
Dim Rng As Range
Dim Rstart As Long ' start of range row
Dim Rend As Long ' end of range row
Dim Target As Range ' destination of copy action
Dim DelRng As Range ' range to delete
Rstart = 6
Rend = 1577
Application.ScreenUpdating = False
Do
Set Rng = Range(Cells(Rstart, "C"), Cells(Rend, "C"))
Set Target = Cells(Rstart - 1, "D")
Set DelRng = Range(Cells(Rstart, "B"), Cells(Rend, "C"))
Rng.Copy
TargetPasteSpecial Paste:=xlPasteAll, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=True
DelRng.Delete Shift:=xlUp
Rstart = Rstart + 1
Loop Until Rstart = Rend
With Application
.CutCopyMode = False
.ScreenUpdating = False
End With
End Sub
Primary precaution to take is to understand the code. Start and End rows are specified at the top. They are used to set 3 ranges in columns C, D and B:C. Initially, they are precisely your 3 ranges Range("C6:C1577"), Range("D5"), Range("B6:C1577"). The code copies from the first range to the second and then deletes the third. It does so without selecting anything because once VBA is told where a range is it doesn't need to select it.
You will notice that there is no equivalent of your Range("C7").Activate. That's because C7 is within the range Range("B6:C1577") which is earmarked for destruction. It makes no difference which cell in it is active. However, I have some doubt about the deletion and whether you actually meant to delete only this cell (which your code doesn't do). Please check my code against your intentions in this regard.
Now the critical part. That's the loop. On each iteration the 3 ranges are moved one row down. The line of code requiring your attention is this one.
Loop Until Rng.Row = Rend
The loop will continue until the first row of the first range is equal to Rend. That means that there will be 1571 loops - probably enough time to have a coffee and a chat even while screen updating is turned off. But even this fearsome number is definitely wrong. Your question gives no clue as to your needs but I guess it should be like Loop Until Rng.Row = (411278 - Rend), give or take 1. I didn't want to enter into an argument about this final, last row (which tends to be omitted in loops) while not believing that your number of rows is invariable. I think it should be replaced with a formula that finds the last existing row in a particular column.
However, your question was how to advance the ranges. My code does that beautifully. Enjoy the show.

Speeding Up a Loop in VBA

I am trying to speed up a loop in VBA with over 25,000 line items
I have code that is stepping down through a spread sheet with over 25,000 lines in it. Right now the code loops thought each cell to see if the Previous cell values match the current cell values. If they do not match it inserts a new blank line. Right now the code take over 5 hours to complete on a pretty fast computer. Is there any way I can speed this up?
With ActiveSheet
BottomRow4 = .Cells(.Rows.Count, "E").End(xlUp).Row
End With
Do
Cells(ActiveCell.Row, 5).Select
Do
ActiveCell.Offset(1, 0).Select
'Determines if previous cells is the same as current cells
Loop Until (ActiveCell.Offset(0, -1) & ActiveCell <>
ActiveCell.Offset(1, -1) & ActiveCell.Offset(1, 0))
'Insert Blank Row if previous cells do not match current cells...
Rows(ActiveCell.Offset(1, 0).Row & ":" & ActiveCell.Offset(1,
0).Row).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
BottomRow4 = BottomRow4 + 1
Loop Until ActiveCell.Row >= BottomRow4
Similarly to when deleting rows, you can save your inserts until you're done looping.
Run after selecting a cell at the top of the column you want to insert on (but not on row 1):
Sub Tester()
Dim c As Range, rngIns As Range, sht As Worksheet
Dim offSet As Long, cInsert As Range
Set sht = ActiveSheet
For Each c In sht.Range(Selection, _
sht.Cells(sht.Rows.Count, Selection.Column).End(xlUp)).Cells
offSet = IIf(offSet = 0, 1, 0) '<< toggle offset
If c.offSet(-1, 0).Value <> c.Value Then
'This is a workaround to prevent two adjacent cells from merging in
' the rngInsert range being built up...
Set cInsert = c.offSet(0, offSet)
If rngIns Is Nothing Then
Set rngIns = cInsert
Else
Set rngIns = Application.Union(cInsert, rngIns)
End If
End If
Next c
If Not rngIns Is Nothing Then
rngIns.EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End If
End Sub
Edit: runs in 3 secs on 25k rows populated using ="Val_" & ROUND(RAND()*1000), converted to values, then sorted.
Insert If Not Equal
Sub InsertIfNotEqual()
Const cSheet As Variant = 1 ' Worksheet Name/Index
Const cFirstR As Long = 5 ' First Row
Const cCol As Variant = "E" ' Last-Row-Column Letter/Number
Dim rng As Range ' Last Cell Range, Union Range
Dim vntS As Variant ' Source Array
Dim vntT As Variant ' Target Array
Dim i As Long ' Source Array Row Counter
Dim j As Long ' Target Array Row Counter
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
On Error GoTo ProcedureExit
' In Worksheet
With ThisWorkbook.Worksheets(cSheet)
' Determine the last used cell in Last-Row-Column.
Set rng = .Columns(cCol).Find("*", , xlFormulas, , , xlPrevious)
' Copy Column Range to Source Array.
vntS = .Cells(cFirstR, cCol).Resize(rng.Row - cFirstR + 1)
End With
' In Arrays
' Resize 1D Target Array to the first dimension of 2D Source Array.
ReDim vntT(1 To UBound(vntS)) As Long
' Loop through rows of Source Array.
For i = 2 To UBound(vntS)
' Check if current value is equal to previous value.
If vntS(i, 1) <> vntS(i - 1, 1) Then
' Increase row of Target Array.
j = j + 1
' Write Source Range Next Row Number to Target Array.
vntT(j) = i + cFirstR
End If
Next
' If no non-equal data was found.
If j = 0 Then Exit Sub
' Resize Target Array to found "non-equal data count".
ReDim Preserve vntT(1 To j) As Long
' In Worksheet
With ThisWorkbook.Worksheets(cSheet)
' Set Union range to first cell of row in Target Array.
Set rng = .Cells(vntT(1), 2)
' Check if there are more rows in Target Array.
If UBound(vntT) > 1 Then
' Loop through the rest of the rows (other than 1) in Target Array.
For i = 2 To UBound(vntT)
' Add corresponding cells to Union Range. To prevent the
' creation of "consecutive" ranges by Union, the resulting
' cells to be added are alternating between column A and B
' (1 and 2) using the Mod operator against the Target Array
' Row Counter divided by 2.
Set rng = Union(rng, .Cells(vntT(i), 1 + i Mod 2))
Next
End If
' Insert blank rows in one go.
rng.EntireRow.Insert
End With
ProcedureExit:
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
Edited: Added two options: didn't test for speed. I thought test2() would have been faster but I'm not certain depending on number of rows.
Untested, but just something I thought of quickly. If I'll remember I'll come back to this later because I think there are faster ways
Sub Test1()
Dim wsSheet As Worksheet
Dim arrSheet() As Variant
Dim collectRows As New Collection
Dim rowNext As Long
Application.ScreenUpdating = False
Application.EnableEvents = False
Const ColCheck As Integer = 6
Set wsSheet = ActiveSheet
arrSheet = wsSheet.Range("A1").CurrentRegion
For rowNext = UBound(arrSheet, 1) To LBound(arrSheet, 1) + 1 Step -1
If arrSheet(rowNext, ColCheck) <> arrSheet(rowNext - 1, ColCheck) Then collectRows.Add rowNext
Next rowNext
For rowNext = 1 To collectRows.Count
wsSheet.Cells(collectRows(rowNext), 1).EntireRow.Insert
Next rowNext
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Second Option inserting all at once:
I used a string here because union would change rows next to each other into one larger range. Instead of Range("1:1", "2:2") it would create ("1:2") and that won't insert the way you need. I don't know of a cleaner way, but there probably is.
Sub Test2()
Dim wsSheet As Worksheet
Dim arrSheet() As Variant
Dim collectRows As New Collection
Dim rowNext As Long
Dim strRange As String
Dim cntRanges As Integer
Dim rngAdd As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
Const ColCheck As Integer = 6
Set wsSheet = ActiveSheet
arrSheet = wsSheet.Range("A1").CurrentRegion
For rowNext = UBound(arrSheet, 1) To LBound(arrSheet, 1) + 1 Step -1
If arrSheet(rowNext, ColCheck) <> arrSheet(rowNext - 1, ColCheck) Then
strRange = wsSheet.Cells(rowNext, 1).EntireRow.Address & "," & strRange
cntRanges = cntRanges + 1
If cntRanges > 10 Then
collectRows.Add Left(strRange, Len(strRange) - 1)
strRange = vbNullString
cntRanges = 0
End If
End If
Next rowNext
If collectRows.Count > 0 Then
Dim i As Long
For i = 1 To collectRows.Count
Set rngAdd = Range(collectRows(i))
rngAdd.Insert
Next i
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

Faster code for cuting 'good row range' from sh2 to sh1?

Does it exist any way to make this code run faster as it goes one row by one row ?
Sub cut_good_row_range_from_sh2_to_sh1()
Application.ScreenUpdating = False
For i = 2 To Sheets("sheet1").Cells(Rows.Count, "A").End(xlUp).Row
For j = 2 To Sheets("sheet2").Cells(Rows.Count, "A").End(xlUp).Row
'Caution: I want to cut BB:BD, so I select BA:BD !
If Sheets("sheet1").Range("A" & i).Value = Sheets("sheet2").Range("A" & j).Value Then
Sheets("sheet2").Range("BA" & j & ":BS" & j).Cut Sheets("sheet1").Range("BA" & i & ":BS" & i)
End If
Next j
Next i
Application.ScreenUpdating = True
End Sub
Thanks ;)
It has been demonstrated on SO many times that looping over ranges is slow, and looping over variant arrays is much faster.
The 'best' method depends on the specifics of the use case. Making as few assumptions as I can, this demo shows how effective it can be. The assumptions made are
Data only is required, Format is not transfered.
No Formulas exist in the Destination range (If they do, they will be overwritten with their current value)
This is a simplistic example, further optimisations can be made.
Sub Demo()
Dim Found As Boolean
Dim i As Long, j As Long, k As Long
Dim rSrcA As Range, rSrc As Range
Dim vSrcA As Variant, vSrc As Variant
Dim rDstA As Range, rDst As Range
Dim vDstA As Variant, vDst As Variant
Dim rClear As Range
' Get references to Source Data Range and Variant Array
With Worksheets("Sheet2")
Set rSrcA = Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
vSrcA = rSrcA.Value
Set rSrc = .Range("BA1:BS1").Resize(UBound(vSrcA, 1))
vSrc = rSrc
End With
' Get references to Destination Data Range and Variant Array
With Worksheets("Sheet1")
Set rDstA = Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
vDstA = rDstA.Value
Set rDst = .Range("BA1:BS1").Resize(UBound(vDstA, 1))
vDst = rDst
End With
' Loop Source
For i = 1 To UBound(vSrcA, 1)
' Loop Destination
For j = 1 To UBound(vDstA, 1)
' Compare
If vSrcA(i, 1) = vDstA(j, 1) Then
Found = True
' Update Destination Data Array, to be copied back to sheet later
For k = 1 To UBound(vSrc, 2)
vDst(j, k) = vSrc(i, k)
Next
End If
Next
' If match found, track Source range to clear later
If Found Then
If rClear Is Nothing Then
Set rClear = rSrc.Rows(i)
Else
Set rClear = Union(rClear, rSrc.Rows(i))
End If
Found = False
End If
Next
' Update Destination Range
rDst.Value = vDst
' Clear Source Range
rClear.ClearContents
End Sub
When run on a test data set of 15 source rows and 200 destination rows, this reduced execution time from about 17s to about 10ms

Resources