Hi I have a column of 0's and 1's I want to create a running total of the non 0 values un-till it reaches a cell value of 0. Once it hits zero it should, return an empty cell, reset to 0, and begin again from 1 at the next cell value of 1.
Any help would be appreciated, including what I might want to look at to help.
Editing with current solution:
Ive found this solution that works, how would I go about making this a function instead of using this Sub()?
Sub test()
Dim value As Integer
value = 0
For i = 1 To Range("Table2").Rows.Count
If ThisWorkbook.Worksheets("Sheet1").Range("Table2[Current Col]").Cells(i) = 0 Then
value = 0
Range("Table2[New Column]")(i) = ""
ElseIf ThisWorkbook.Worksheets("Sheet1").Range("Table2[Current Col]").Cells(i) = 1 Then
value = value + 1
Range("Table2[New Column]")(i) = value
End If
Next i
End Sub
Incrementing Groups
Use variables to avoid long unreadable lines.
Option Explicit
Sub test()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim srg As Range: Set srg = ws.Range("Table2[Current Col]")
Dim drg As Range: Set drg = ws.Range("Table2[New Col]")
Dim sValue As Variant
Dim dValue As Variant
Dim iValue As Long
Dim i As Long
For i = 1 To srg.Cells.Count
' Read from source cell into a variable ('sValue').
sValue = srg.Cells(i).Value
' Test and write result to a variable ('dValue').
If IsNumeric(sValue) Then
If sValue = 1 Then
iValue = iValue + 1
dValue = iValue
End If
Else
iValue = 0
dValue = Empty
End If
' Write from the variable ('dValue') to the destination cell.
drg.Cells(i).Value = dValue
Next i
End Sub
As a UDF:
Function CountUp(rng As Range)
Dim arr, arrOut(), v As Long, i As Long
arr = rng.Columns(1).value
ReDim arrOut(1 To UBound(arr, 1), 1 To UBound(arr, 2))
v = 0
For i = 1 To UBound(arr, 1)
v = IIf(arr(i, 1) = 1, v + 1, 0)
arrOut(i, 1) = v
Next i
CountUp = arrOut
End Function
If your Excel version has the "autospill" feature then you can enter it as a normal function: if not then you need to select the whole output range and enter the formula using Ctrl+Shift+Enter
Related
I have found some Q/A to delete rows with empty cells in a chosen column like here. My need is a bit different, the columns are selected by the user, but this is not important.
EDIT : what is important in my use case is to delete the rows where all the cells are empty for these columns i.e. the selected columns.
The following code is working, but can only process 1,000 lines per minute on my i5. In my use case, the datasheet contains several 100k lines which means hours to process. This is not acceptable. Is there a trick to perfom it quickly please?
Sub DeleteRowsOfEmptyColumn() 'sh As Worksheet, col As String)
Application.ScreenUpdating = False
Dim sh As Excel.Worksheet: Set sh = ActiveWorkbook.ActiveSheet
Dim col As Range: Set col = Selection.EntireColumn
Dim cell
Dim area As Range: Set area = Intersect(sh.UsedRange, col)
For i = area.Rows.Count To 1 Step -1 'For Each row In area.Rows
fKeep = False
For Each cell In area.Rows(i).Cells
If Not IsEmpty(cell) Then
fKeep = True
Exit For
End If
Next cell
If Not fKeep Then
sh.Rows(i).Delete 'rowsToDelete.Add i
End If
Next i
Application.ScreenUpdating = True
End Sub
Example:
Before:
After:
Delete Empty Row Ranges
This is a basic example. Your feedback regarding the efficiency is appreciated.
Option Explicit
Sub DeleteRowsOfEmptyColumn()
Application.ScreenUpdating = False
Dim ws As Worksheet: Set ws = ActiveSheet ' improve
Dim crg As Range: Set crg = Selection.EntireColumn ' Columns Range
Dim srg As Range: Set srg = Intersect(ws.UsedRange, crg) ' Source Range
Dim drg As Range ' Delete Range
Dim arg As Range ' Area Range
Dim rrg As Range ' Row Range
For Each arg In srg.Areas
For Each rrg In arg.Rows
If Application.CountA(rrg) = 0 Then
If drg Is Nothing Then
Set drg = rrg
Else
Set drg = Union(drg, rrg)
End If
End If
Next rrg
Next arg
If Not drg Is Nothing Then drg.Delete
Application.ScreenUpdating = True
MsgBox "Rows deleted.", vbInformation
End Sub
Please, try the next way. It will process selected columns or columns having at least a selected cell. It will delete entire rows of the sheet, for the cases of all selected columns empty rows. The code only selects the rows in discussion. If they are the appropriate ones, on the last code line, Select should be replaced with Delete. It should be very fast, even for larger ranges, iterating only between blank cells range:
Sub DeleteRowsOfEmptyColumnsCells()
Dim sh As Excel.Worksheet: Set sh = ActiveSheet
Dim col As Range: Set col = Selection.EntireColumn
Dim area As Range: Set area = Intersect(sh.UsedRange, col)
Dim firstCol As Long: firstCol = area.Column: Stop
Dim areaV As Range, arr, rngDel As Range, i As Long
On Error Resume Next 'only for the case of no any empty rows existence
Set areaV = area.SpecialCells(xlCellTypeBlanks) 'a range of only empty cells
On Error GoTo 0
arr = getRows(areaV) 'extract all rows and number of columns
For i = 0 To UBound(arr(0)) 'iterate between all existing rows
If Intersect(sh.rows(arr(0)(i)), areaV).cells.count = arr(1) Then
If rngDel Is Nothing Then
Set rngDel = sh.cells(arr(0)(i), firstCol)
Else
Set rngDel = Union(rngDel, sh.cells(arr(0)(i), firstCol))
End If
End If
Next i
If Not rngDel Is Nothing Then rngDel.EntireRow.Select 'if it looks OK, Select should be replaced with Delete
End Sub
Function getRows(rng As Range) As Variant
Dim A As Range, i As Long, countC As Long
Dim arrCol, arrR, k As Long, R As Long, mtchC, mtchR
ReDim arrCol(rng.cells.count): ReDim arrR(rng.cells.count)
For Each A In rng.Areas
For i = 1 To A.Columns.count
For j = 1 To A.rows.count
mtchC = Application.match(A.cells(j, i).Column, arrCol, 0)
mtchR = Application.match(A.cells(j, i).row, arrR, 0)
If IsError(mtchC) Then
arrCol(k) = A.cells(j, i).Column: k = k + 1
End If
If IsError(mtchR) Then
arrR(R) = A.cells(j, i).row: R = R + 1
End If
Next j
Next i
Next A
ReDim Preserve arrR(R - 1)
getRows = Array(arrR, k)
End Function
I am working on similar kind of project. I have chosen to read the data into an array, and then work with the data in the array which improves run time significantly. Here is a copy of the function that I have used to delete / transform the data set:
Option Explicit
Option Base 1
Public Function RemoveRowFromArray(Arr As Variant, Element As String, Col As Long) As Variant
Dim i, j, c, count As Long
Dim TempArr() As Variant
For i = LBound(Arr, 1) To UBound(Arr, 1) ' looping through the columns to get desired value
If Arr(i, Col) = Element Then
count = count + 1 ' Counting the number of Elements in array / matrix
For j = i To (UBound(Arr, 1) - 1) ' Looping from the row where Element is found
For c = LBound(Arr, 2) To UBound(Arr, 2) ' Moving all elements in row 1 row up
Arr(j, c) = Arr(j + 1, c)
Next c
Next j
End If
Next i
' Populating TempArr to delete the last rows
ReDim TempArr((UBound(Arr, 1) - count), UBound(Arr, 2))
For i = LBound(TempArr, 1) To UBound(TempArr, 1)
For j = LBound(TempArr, 2) To UBound(TempArr, 2)
TempArr(i, j) = Arr(i, j)
Next j
Next i
RemoveRowFromArray = TempArr
End Function
I tested this and seems to work perfectly. A few important matters to keep in mind
Option Base 1 - This is important, when you declare an arr in VBA it starts at Index 0, when you read the arr from a data set in Excel [arr = sheet1.Range("A:D")] then the arr starting index is 1, Option Base 1 will ensure that all arr start at Index 1.
The function variables are :
Arr - the array / matrix
Element - the string that you wish to search for (in your case it would be blank)
Col - is the column number in which Element is.
I have an excel sheet with bunch of "nan" and blank cells and i don't want my for loop to evaluate these as shown below in the image
![image][1]
This is my code below and it's taking all the blank cell values as 0 and messing with my code.
For j = LBound(ARINC_CHA_DATA_array, 2) To UBound(ARINC_CHA_DATA_array, 2)
For i = LBound(ARINC_CHA_DATA_array, 1) To UBound(ARINC_CHA_DATA_array, 1)
If ARINC_CHA_DATA_array(i, j) <> "" Or ARINC_CHA_DATA_array(i, j) = "nan" Then GoTo Ravi
...........code
...........code
End If
Ravi:
Next i
Next j
```[![enter image description here][2]][2]
[1]: https://i.stack.imgur.com/ip2B9.png
[2]: https://i.stack.imgur.com/bTDou.png
Select Case vs If...Then...Else When Looping Through an Array
Use shorter variable names to make the code more readable.
GoTo is kind of reserved for error-handling and its use can most often be avoided.
The opposite of A = B OR C = D is A <> B AND C <> D.
That is why Test2 is preferred compared to Test3 (no need for the Else statement).
All three codes do the same: they read the values from a range into an array, then loop through the elements of the array doing ... code (at the moment nothing) and write the 'modified' values from the array back to the range.
Caution: If there are formulas in the range, after running this code, they will be replaced with values.
Option Explicit
Sub Test1()
Dim rg As Range: Set rg = ActiveSheet.Range("A1:J10")
Dim Acd As Variant: Acd = rg.Value
Dim Item As Variant
Dim j As Long, i As Long
For j = LBound(Acd, 2) To UBound(Acd, 2)
For i = LBound(Acd, 1) To UBound(Acd, 1)
Item = Acd(i, j)
Select Case CStr(Item)
Case "", "nan"
' do nothing
Case Else
' ... code
End Select
Next i
Next j
rg.Value = Acd
End Sub
Sub Test2()
Dim rg As Range: Set rg = ActiveSheet.Range("A1:J10")
Dim Acd As Variant: Acd = rg.Value
Dim Item As Variant
Dim j As Long, i As Long
For j = LBound(Acd, 2) To UBound(Acd, 2)
For i = LBound(Acd, 1) To UBound(Acd, 1)
Item = Acd(i, j)
If CStr(Item) <> "" And CStr(Item) <> "nan" Then
' ... code
'Else ' you don't need this
' do nothing
End If
Next i
Next j
rg.Value = Acd
End Sub
Sub Test3()
Dim rg As Range: Set rg = ActiveSheet.Range("A1:J10")
Dim Acd As Variant: Acd = rg.Value
Dim Item As Variant
Dim j As Long, i As Long
For j = LBound(Acd, 2) To UBound(Acd, 2)
For i = LBound(Acd, 1) To UBound(Acd, 1)
Item = Acd(i, j)
If CStr(Item) = "" Or CStr(Item) = "nan" Then
' do nothing
Else
' ... code
End If
Next i
Next j
rg.Value = Acd
End Sub
I'm trying to make a macro for where a user inputs a number and the even numbers are repeated in an array. I have got the code for repeating the numbers from 0-n (n being the number inputted). However, I don't know how to go about repeating the even numbers twice.
Sub Macro3()
For n = 1 To Worksheets("Sheet1").Cells(1, 2) + 1
Cells(2, 1 + n).Select
ActiveCell.FormulaR1C1 = (n - 1)
Next
End Sub
Below is the output
Current code vs what I really want
Write an Array of Integers
Writes an array of integers between 0 and the specified value in cell B1 to a row range starting from B2. Even numbers are written twice (one worksheet).
Initial Solution
This is a slow solution meant to be educational in understanding object variables (workbook-worksheet-range), ranges (Resize, Offset), loops,...
Option Explicit
Sub WriteArrayOfIntegersRange()
Const ProcTitle As String = "Write Array of Integers Range"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
' Create a reference to the source cell.
Dim sCell As Range: Set sCell = ws.Range("B1")
' Write the value of the source cell to a variable.
Dim sValue As Variant: sValue = sCell.Value
Dim LastInteger As Long
' Validate the source cell value.
If IsNumeric(sValue) Then ' is a number
LastInteger = Abs(CLng(sValue)) ' positive ('Abs'), whole ('CLng')
Else ' is not a number
MsgBox "The value in cell '" & sCell.Address(0, 0) & "' ('" _
& sValue & "' is not a number.", vbCritical, ProcTitle
Exit Sub
End If
' Create a reference to the first destination cell.
Dim dCell As Range: Set dCell = ws.Range("B2"): dCell.Value = 0
Dim Size As Long: Size = 1
Dim n As Long
' Loop through the numbers and apply alternating row size (1 or 2)
' and column offset (2 or 1) before writing.
For n = 1 To LastInteger
Set dCell = dCell.Offset(, Size) ' define next first cell
Size = 2 - n Mod 2 ' calculate the size (Odd = 1, Even = 2)
dCell.Resize(, Size).Value = n ' write to the resized row range
Next n
' Clear the range to the right of the last cell to remove any previous data.
Dim crrg As Range
With dCell.Offset(, Size) ' define next first cell
' Define the range from the next first to the last worksheet cell
' in the row.
Set crrg = .Resize(, ws.Columns.Count - .Column + 1)
End With
crrg.Clear ' or crrg.ClearContents
MsgBox "Array of numbers written.", vbInformation, ProcTitle
End Sub
Using Arrays
This is a more advanced solution that utilizes the multi-purpose GetArrayOfIntegers function. By modifying the related constants (Function Parameters) in the following procedure, you can easily change the output.
Note that it returns the results in another worksheet (Sheet2).
The last procedure is created for anyone to quickly get a flavor of the GetArrayOfIntegers function. Just add a new workbook, add a new module and copy the codes to it. Modify the function parameters in the last procedure to get different results in the Immediate window (Ctrl+G).
Sub WriteArrayOfIntegers()
' Needs the 'GetArrayOfIntegers' function.
Const ProcTitle As String = "Write Array of Numbers"
' Source
Const sName As String = "Sheet1"
Const sCellAddress As String = "B1"
' Destination
Const dName As String = "Sheet2"
Const dfCellAddress As String = "B2"
' Function Parameters ' experiment with these five parameters
Const EvensCount As Long = 2
Const OddsCount As Long = 1
Const DoReturnRow As Boolean = True
Const IncludeZero As Boolean = True
Const IsZeroOdd As Boolean = True
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Create a reference to the source cell.
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim sCell As Range: Set sCell = sws.Range(sCellAddress)
' Write the value of the source cell to a variable.
Dim sValue As Variant: sValue = sCell.Value
Dim LastInteger As Long
' Validate the source cell value.
If IsNumeric(sValue) Then ' is a number
LastInteger = Abs(CLng(sValue)) ' positive ('Abs'), whole ('CLng')
Else ' is not a number
MsgBox "The value in cell '" & sCell.Address(0, 0) & "' ('" _
& sValue & "' is not a number.", vbCritical, ProcTitle
Exit Sub
End If
' Return the result (an array) of the 'GetArrayOfIntegers' function.
Dim Data As Variant: Data = GetArrayOfIntegers( _
LastInteger, EvensCount, OddsCount, DoReturnRow, IncludeZero, IsZeroOdd)
' Without the constants it would be:
'Data = GetArrayOfIntegers(LastInteger, 2, 1, True, True, True)
If IsEmpty(Data) Then Exit Sub
Dim drCount As Long: drCount = UBound(Data, 1)
Dim dcCount As Long: dcCount = UBound(Data, 2)
' Create a reference to the first destination cell.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfCell As Range: Set dfCell = dws.Range(dfCellAddress)
' Clear all cells next to (to the right of) and below
' the first destination cell.
Dim dcrg As Range: Set dcrg = dfCell.Resize( _
dws.Rows.Count - dfCell.Row + 1, dws.Columns.Count - dfCell.Column + 1)
dcrg.Clear ' or dcrg.ClearContents
' Create a reference to the destination range.
Dim drg As Range: Set drg = dfCell.Resize(drCount, dcCount)
' Write the values from the array to the destination range.
drg.Value = Data
MsgBox "Array of numbers written.", vbInformation, ProcTitle
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Author: VBasic2008
' Dates: 20211101
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns an array of integers in a 2D one-based array.
' Remarks: The first element is always 0 or 1.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetArrayOfIntegers( _
ByVal LastInteger As Long, _
Optional ByVal EvensCount As Long = 1, _
Optional ByVal OddsCount As Long = 1, _
Optional ByVal DoReturnRow As Boolean = False, _
Optional ByVal IncludeZero As Boolean = False, _
Optional ByVal IsZeroOdd As Boolean = False) _
As Variant
Dim eoArr() As Long: ReDim eoArr(0 To 1)
eoArr(0) = EvensCount: eoArr(1) = OddsCount
Dim zCount As Long
If IncludeZero Then
If IsZeroOdd Then zCount = OddsCount Else zCount = EvensCount
End If
Dim iMod As Long: iMod = LastInteger Mod 2
Dim eCount As Long: eCount = Int(LastInteger / 2)
Dim oCount As Long: oCount = Int(LastInteger / 2) + iMod
Dim dtCount As Long
dtCount = eCount * EvensCount + oCount * OddsCount + zCount
Dim Data As Variant
Dim dt As Long: dt = 1
Dim n As Long
Dim r As Long
If DoReturnRow Then
ReDim Data(1 To 1, 1 To dtCount)
If zCount > 0 Then
For dt = 1 To zCount: Data(1, dt) = 0: Next dt
End If
For n = 1 To LastInteger
For r = 1 To eoArr(n Mod 2)
Data(1, dt) = n
dt = dt + 1
Next r
Next n
Else
ReDim Data(1 To dtCount, 1 To 1)
If zCount > 0 Then
For dt = 1 To zCount: Data(dt, 1) = 0: Next dt
End If
For n = 1 To LastInteger
For r = 1 To eoArr(n Mod 2)
Data(dt, 1) = n
dt = dt + 1
Next r
Next n
End If
GetArrayOfIntegers = Data
End Function
' This is an unrelated example to play with.
' Note that changing the fourth parameter will make no difference since
' the results are written to the Immediate window (Ctrl+G).
Sub GetArrayOfIntegersTEST()
' Needs the 'GetArrayOfIntegers' function.
Dim Data As Variant: Data = GetArrayOfIntegers(4, 3, 2, False, False, False)
Dim r As Long, c As Long
For r = 1 To UBound(Data, 1)
For c = 1 To UBound(Data, 2)
Debug.Print Data(r, c)
Next c
Next r
End Sub
Fast alternative via ArrayList
Working with an ArrayList (disposing btw of methods like .Sort,.Remove, .Insert, .Reverse) may be a convenient way to manipulate array data in a very readable way. It is not part of VBA, but can be accessed easily via late binding (referring to .Net library mscorlib.dll).
Option Explicit ' code module head
Sub DoubleEvenNumbersGreaterOne()
'a) define upper limit
Dim ws As Worksheet
Set ws = Sheet1 ' << change to project's sheet Code(Name)
Dim Limit As Long
Limit = ws.Range("B1")
'b) declare ArrayList
Dim arr As Object ' late bind .Net mscorlib.dll
Set arr = CreateObject("System.Collections.ArrayList")
'c) populate list array
arr.Add 0 ' start adding with zero
Dim i As Long
For i = 1 To Limit ' loop through sequence 1:Limit
arr.Add i ' add current number
If i Mod 2 = 0 Then arr.Add i ' additional even number
Next
'd) get array
Dim a As Variant: a = arr.ToArray ' change ArrayList object to VBA array
'Debug.Print Join(a, "|") ' optional check in VB Editor's immediate window
'e) write 0-based 1-dim array to ws (here: Sheet1) or declare another target worksheet (e.g. ws2)
With ws.Range("B2")
.EntireRow = vbNullString ' empty target row
.Resize(1, UBound(a) + 1) = a ' write values into correct number of cells
End With
End Sub
A formula oriented approach // late edit as of 11/1 2021
a) A first and very elementary way would be to
enter formula =COLUMN(A1)-INT((COLUMN(A1)+2)/3) into cell B2 and to
copy into the right neighbour cells as long as you get the wanted maximum
b) Refining this approach you can code the following udf accepting the wanted maximum as argument (note that I changed the flat Column reference to a vertical Row reference to simplify calculation of the actual maxima):
Function Sequ(ByVal maxNo As Long)
Dim myFormula As String
myFormula = Replace("=ROW(1:$)-INT((ROW(1:$)+2)/3)", "$", maxNo + maxNo \ 2 + 1)
Sequ = Application.Transpose(Evaluate(myFormula))
End Function
A direct formula entry of e.g. =Sequ(10) into B2 benefitting from the newer dynamic features of vers. 2019+/MS 365 would display all (row) elements automatically in a so called spill range without need of further inputs.
Using VBA to display results in VB Editor's immediate window could be coded as follows: Debug.Print Join(Sequ(10), "|") resulting in
0|1|2|2|3|4|4|5|6|6|7|8|8|9|10|10
or to assign the results to a variable that can be used in further code.
Your code is really ok, just add question is number even and one more variable to see where to write. Also just change n loop from 0:
Sub Macro3()
For n = 0 To Worksheets("Sheet1").Cells(1, 2)
a = a + 1
Cells(2, 2 + a).Select
ActiveCell.FormulaR1C1 = n
'check if number is even and check if a > 1 because we don't want to repeat 0
If n Mod 2 = 0 And a > 1 Then
a = a + 1
Cells(2, 2 + a).Select
ActiveCell.FormulaR1C1 = n
End If
Next
End Sub
Try this code
Sub Test()
Dim v, ws As Worksheet, i As Long, ii As Long, n As Long
Set ws = ThisWorkbook.Worksheets("Sheet1")
v = ws.Range("B1").Value
If Not IsNumeric(v) Or IsEmpty(v) Then MsgBox "Must Be Number", vbExclamation: Exit Sub
ReDim a(1 To (v / 2) + v)
For i = 1 To v
If i Mod 2 = 0 Then
For ii = 1 To 2
n = n + 1: a(n) = i
Next ii
Else
n = n + 1: a(n) = i
End If
Next i
Range("C2").Resize(, UBound(a)).Value = a
End Sub
Sub adress()
Dim s As Long
Dim h As Long
Dim n As Long
Dim i As Long
s = 1
n = 1
h = 1
For n = 1 To 1800
For i = 1 To 2000
If ActiveSheet.Cells(h + 1, 13) = ActiveSheet.Cells(s + 1, 32) Then
ActiveSheet.Cells(h + 1, 48) = ActiveSheet.Cells(s + 1, 36)
ActiveSheet.Cells(h + 1, 51) = ActiveSheet.Cells(s + 1, 37)
End If
s = s + 1
Next i
h = h + 1
i = 1
Next n
End Sub
This code is written to grab a value in a column of an excel spread sheet, then go to the next column and search the whole column for a matching value. Once that is found it will print the value that is in a cell in the same row of the value in the second column it found, into a cell in the same row as the original value it was trying to match.
While the inner loop works and my code will do the correct process when ran, it only does it for one value in the first column. I have tried using ranges in the For Loops, I have tried do while loops and do until loops. If i manually change the value of "h" and run the code it will progress down the column and print the correct information but i cannot get "h" to update on its own.
Nested For Next Loops
Although Exit For and turning off the two application settings are used, the first procedure still takes 45 seconds on my machine (without the 'improvements' it might take half an hour).
In the second code the inner loop is replaced with Application.Match and the operations are performed using arrays. It takes less than a second.
The Code
Option Explicit
Sub loopSlow()
Dim i As Long
Dim k As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With ActiveSheet
For i = 2 To 1801
For k = 2 To 2001
If .Cells(i, 13).Value = .Cells(k, 32).Value Then
.Cells(i, 48).Value = .Cells(k, 36).Value
.Cells(i, 51).Value = .Cells(k, 37).Value
Exit For
End If
Next k
Next i
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Sub loopFast()
' Source
Const sName As String = "Sheet2"
Const sColsList As String = "AF,AJ,AK"
Const sFirstRow As Long = 2
' Destination (Lookup)
Const dName As String = "Sheet2"
Const dColsList As String = "M,AV,AY"
Const dFirstRow As Long = 2
' Define workbook.
Dim wb As Workbook: Set wb = ThisWorkbook
' Declare variables.
Dim ws As Worksheet
Dim rg As Range
Dim Cols() As String
Dim cUpper As Long
Dim cOffset As Long
Dim n As Long
' Write values from Source Columns to arrays of Data Array.
Cols = Split(sColsList, ",")
cUpper = UBound(Cols)
Set ws = wb.Worksheets(sName)
Set rg = ws.Cells(ws.Rows.Count, Cols(0)).End(xlUp)
Set rg = ws.Range(ws.Cells(sFirstRow, Cols(0)), rg)
Dim Data As Variant: ReDim Data(0 To cUpper)
For n = 0 To cUpper
cOffset = ws.Columns(Cols(n)).Column - rg.Column
Data(n) = rg.Offset(, cOffset).Value
Next n
' Write values from Lookup Column to Lookup Array of Result Array.
Cols = Split(dColsList, ",")
Set ws = wb.Worksheets(dName)
Set rg = ws.Cells(ws.Rows.Count, Cols(0)).End(xlUp)
Set rg = ws.Range(ws.Cells(dFirstRow, Cols(0)), rg)
Dim Result As Variant: ReDim Result(0 To cUpper)
Result(0) = rg.Value
' Define the (remaining) Write Arrays of Result Array.
Dim ResultNew As Variant: ReDim ResultNew(1 To UBound(Result(0)), 1 To 1)
For n = 1 To cUpper
Result(n) = ResultNew
Next n
' Write values from Data Array to Write Arrays of Result Array.
Dim cIndex As Variant
Dim i As Long
For i = 1 To UBound(Result(0))
cIndex = Application.Match(Result(0)(i, 1), Data(0), 0)
If IsNumeric(cIndex) Then
For n = 1 To cUpper
Result(n)(i, 1) = Data(n)(cIndex, 1)
Next n
End If
Next i
' Write values from Write Arrays of Result Array to Destination Columns.
For n = 1 To cUpper
cOffset = ws.Columns(Cols(n)).Column - rg.Column
rg.Offset(, cOffset).Value = Result(n)
Next n
End Sub
Here are the particulars. Let's say you have a 10 X 10 range of cells- A1:J10 will work fine. What I'm trying to find via VBA is how many pairs of non intersecting ranges containing 5 cells and 4 cells can be derived from the main range of A1:J10. For example, A1:A5 (5 cell subset) and A6:A9 (4 cell subset) would be a valid pair. A1:E5 and A1:A4 would not be a valid pair due to the intersection of ranges at A1. I'm mostly just looking for the number of valid pairs, but if somebody can show how to physically list all the pairs on a worksheet as well that would help out.
Thanks in advance for the help!
Range Subset Combinations
Option Explicit
Sub writeRangePairs()
' Source
Const wsName As String = "Sheet1"
Const srcRange = "A1:J10"
Const RC1 As Long = 5
Const RC2 As Long = 4
' Target
Const tgtFirstCell As String = "L1"
' Other
Dim wb As Workbook
Set wb = ThisWorkbook
' Define Source Range.
Dim ws As Worksheet
Set ws = wb.Worksheets(wsName)
Dim rng As Range
Set rng = ws.Range(srcRange)
' Write all possible range addresses
' to Source Arrays ('Source1', 'Source2').
Dim Source1 As Variant
Source1 = getOneRowOneCol(rng, RC1)
Dim Source2 As Variant
Source2 = getOneRowOneCol(rng, RC2)
' Define Target Array. It is too big,
' but It cannot be bigger than UB1 * UB2.
Dim Target As Variant
ReDim Target(1 To UBound(Source1) * UBound(Source2), 1 To 3)
Dim i As Long
Dim k As Long
Dim m As Long
' Write values from Source Arrays to Target Array.
For i = 1 To UBound(Source1)
For k = 1 To UBound(Source2)
If Intersect(ws.Range(Source1(i, 1)), ws.Range(Source2(k, 1))) _
Is Nothing Then
m = m + 1
' Write first range address.
Target(m, 1) = Source1(i, 1)
' Write second range address.
Target(m, 2) = Source2(k, 1)
' Write both addresses as one range address. This column
' will contain duplicates which could be removed
' by using a dictionary.
Target(m, 3) = Union(ws.Range(Source1(i, 1)), _
ws.Range(Source2(k, 1))).Address(0, 0)
End If
Next k
Next i
' Write values from Target Array to Target Range. Since Target Array
' is too big, we are using 'm' instead of 'UBound(Target, 1)'.
ws.Range(tgtFirstCell).Resize(m, UBound(Target, 2)).Value = Target
End Sub
Function getOneRowOneCol(SourceRange As Range, _
ByVal NumberOfCells As Long) _
As Variant
Dim r As Long
r = SourceRange.Rows.Count
Dim c As Long
c = SourceRange.Columns.Count
Dim NoRs As Long
NoRs = r * (c - NumberOfCells + 1)
Dim NoCs As Long
NoCs = c * (r - NumberOfCells + 1)
Dim Data As Variant
ReDim Data(1 To NoRs + NoCs, 1 To 1)
Dim rng As Range
Dim i As Long
Dim j As Long
Dim k As Long
' Rows
For i = 1 To r
For j = 1 To c - NumberOfCells + 1
Set rng = SourceRange.Cells(i, j).Resize(, NumberOfCells)
k = k + 1
Data(k, 1) = rng.Address(0, 0)
Next j
Next i
' Columns
For j = 1 To c
For i = 1 To r - NumberOfCells + 1
Set rng = SourceRange.Cells(i, j).Resize(NumberOfCells)
k = k + 1
Data(k, 1) = rng.Address(0, 0)
Next i
Next j
getOneRowOneCol = Data
' Debug.Print UBound(Data)
' For i = 1 To UBound(Data)
' Debug.Print Data(i, 1)
' Next i
End Function