I am assigning numbers their order in which they appear in the list and i do that using countif function in excel something like this,
=COUNTIF(A$2:A2,A2)
Number Count
10 1
10 2
10 3
11 1
11 2
11 3
12 1
I wish to achieve the same using VBA. However, here are the specifics.
I want to take a variable and compute the countif function and then loop them through.
Once the variable has all numbers(array) I want to paste them in a location.
Assuming column A is sorted as per your list above you could use the following.
Dim arr(100,1) as double '100 = arbitrary number for this example
dim n as double
n=1
arr(roW,0) = Cell(roW + 2, 1).value
arr(roW,1) = n
For roW = 1 to 100
IF Cell(roW + 2, 1).value = Cell(roW + 1, 1).value Then
n = Cell(roW + 2, 1).value
Else
n=1
End if
arr(roW,0) = Cell(roW + 2, 1).value
arr(roW,1) = n
Next
Range("C2:D102")=arr
And another option,
Sub GetUniqueAndCountif()
Dim cUnique As Collection
Dim Rng As Range
Dim Cell As Range, nW As Range
Dim sh As Worksheet
Dim vNum As Variant
Set sh = ThisWorkbook.Sheets("Sheet1")
Set Rng = sh.Range("A2", sh.Range("A2").End(xlDown))
Set cUnique = New Collection
On Error Resume Next
For Each Cell In Rng.Cells
cUnique.Add Cell.Value, CStr(Cell.Value)
Next Cell
On Error GoTo 0
For Each vNum In cUnique
Set nW = Cells(Rows.Count, "C").End(xlUp).Offset(1, 0)
nW = vNum
nW.Offset(, 1) = WorksheetFunction.CountIf(Rng, nW)
Next vNum
End Sub
The following code evaluates the results as a single array formula and assigns this to a varaiable v. You can adapt references and add variable declarations as needed.
Sub CountifArray()
v = Evaluate(Replace("INDEX(COUNTIF(OFFSET(y,,,ROW(y)-MIN(ROW(y))+1),y),)", "y", "A2:A8"))
Range("B2:B8") = v
End Sub
This is my suggestion.
Sub Counts()
Dim ws As Worksheet
Set ws = ThisWorkbook.ActiveSheet
Dim lngLastRow As Long
lngLastRow = ws.UsedRange.Rows.Count
Dim Arr() As Variant
'Taking values in column A into an array
Arr = ws.Range("A2:A" & lngLastRow).Value
Dim Arr2() As Variant
'another Array for Countif results
ReDim Arr2(lngLastRow - 2, 0)
Dim count As Long
Dim i As Long, j As Long 'counters
'counting
For i = LBound(Arr) To UBound(Arr)
count = 0
For j = LBound(Arr) To i
If Arr(j, 1) = Arr(i, 1) Then count = count + 1
Next
'filling the array with results
Arr2(i - 1, 0) = count
Next
'sending results back to the worksheet
ws.Range("B2:B" & lngLastRow).Value = Arr2
Set ws = Nothing
End Sub
Related
I am working with a schedule, that I have imported and formatted into my workbook.
I am wanting this to populate Phase in the upper listbox and then when a phase is selected the sub-task associated with those phases are displayed in the bottom listbox.
I want to use an array but I seem to be having problems when the columns are not next to each other or there are "gaps" with the blank cells.
My first attempt using assigning the Array to the currentregion worked but brought all columns and fields in. Listbox1 should contain (ID, PHASE NAME, DURATION, START DATE, FINISH DATE) List box 2 should when a Phase is selected contain the subtasks if any from the column to the right, listed before the next next Phase name. (ID, SUB-TASK NAME, DURATION, START DATE, FINISH DATE)
(See picture)
I have code but its more me trouble-shooting than an actual semi working script.
Dim shT As Worksheet
Dim schnumrng1 As Range
Dim schnumrng2 As Range
Dim schnumrng3 As Range
Dim schnumrng4 As Range
Dim schnumrng5 As Range
Dim schpersonrng As Range
Dim schphaserng As Range
Dim schlistrng As Range
Dim maxschnum
Dim schstatus
Dim schperson
Dim schlistnum
Dim Ar() As String
Dim i As Long
Dim j As Long
Dim rng As Range
Dim cl As Range
Dim lc
'allowevents = True
''Set Screen parameters
'Application.ScreenUpdating = False
'Application.EnableEvents = False
'
Worksheets("Schedule").Visible = True
ThisWorkbook.Worksheets("Schedule").Activate
'
Set shT = Worksheets("Schedule")
maxschnum = shT.Cells(shT.Rows.Count, "A").End(xlUp).Row
Set schnumrng = Range("B5", "B" & maxschnum)
'Set Ranges for the list box
Set schnumrng1 = Range("A5", "A" & maxschnum)
Set schnumrng2 = Range("B5", "B" & maxschnum)
Set schnumrng3 = Range("D5", "D" & maxschnum)
Set schnumrng4 = Range("E5", "E" & maxschnum)
Set schnumrng5 = Range("F5", "F" & maxschnum)
'This is static and not moving to the next line in my for statement / switched to named ranges and errors
Set rng = schnumrng1, schnumrng2, schnumrng3, schnumrng4, schnumrng5
'Set rng = Range("A5,B5,D5,E5,F5")
i = 1
j = 1
For Each lc In schnumrng
If lc <> vbNullString Then
For Each cl In rng
ReDim Preserve Ar(1, 1 To i)
Ar(j, i) = cl.Value
i = i + 1
Next cl
Else
End If
j = j + 1
Next lc
With ScheduleForm.SchMainTasklt
.ColumnCount = i - 1
.ColumnWidths = "50;150;50;50;50"
.List = Ar
End With
My problem then is two fold, trying to use the dynamic ranges or another tool Index? collection? to populate the 1st list box. 2. How to deal with blanks and noncontiguous columns when data is not separated for organization purposes.
I don't know if I figured out your intentions well.
First, only the data in column b, not empty cells, is extracted from listbox1.
Second, when listbox1 is selected, data related to listbox2 is collected through the selected listbox value.
Module Code
Place this code in the module. This is because global variables must be used.
Public vDB As Variant
Public Dic As Object 'Dictionary
Sub test()
Dim shT As Worksheet
Dim maxschnum As Long
Dim Ar() As String
Dim i As Long
Dim j As Long
Dim vC() As Variant
Dim cnt As Integer, n As Integer
Dim c As Integer
Dim s As String, s2 As String
Worksheets("Schedule").Visible = True
ThisWorkbook.Worksheets("Schedule").Activate
'
Set Dic = CreateObject("Scripting.Dictionary") 'New Scripting.Dictionary
Set shT = Worksheets("Schedule")
maxschnum = shT.Cells(shT.Rows.Count, "A").End(xlUp).Row
With shT
vDB = .Range("a5", .Range("f" & maxschnum))
End With
'vC is data colum A,B,D,E,F
vC = Array(1, 2, 4, 5, 6)
s2 = vDB(2, 2)
For i = 2 To UBound(vDB, 1)
s = vDB(i, 2) 'column B
If s = "" Then
n = n + 1
Else
If Dic.Exists(s) Then
Else
If i > 2 Then
Dic(s2) = Dic(s2) & "," & n
End If
Dic.Add s, i
s2 = s
cnt = cnt + 1
ReDim Preserve Ar(1 To 5, 1 To cnt)
For c = 0 To UBound(vC)
Ar(c + 1, cnt) = vDB(i, vC(c))
Next c
End If
n = 0
End If
Next i
Dic(s2) = Dic(s2) & "," & n
' Records information about the data in a dictionary.
' Dic is "phase neme" is Key, Item is "2,4"
' example for KICkOFF
' dic key is "KICKOFF", Item is "5,4"
' 5 is KICOFF's row number in array vDB
' 4 is the number of blank cells related to kickoff.
With ScheduleForm.SchMainTasklt
.ColumnCount = 5
.ColumnWidths = "50;150;50;60;60"
.BoundColumn = 2
'.List = Ar
.Column = Ar 'In the state that the array has been converted to row column, you can use listbox.column.
End With
End Sub
Form Code
Private Sub UserForm_Initialize()
Call test
End Sub
Private Sub SchMainTasklt_Click()
Dim s As String, sItem As String
Dim arr As Variant, vC As Variant
Dim vR() As Variant
Dim st As Long, ed As Long
Dim iLast As Long, iFirst As Long
Dim i As Long, n As Integer
Dim j As Integer
vC = Array(1, 3, 4, 5, 6) 'data colums A,C,D,E,F
s = SchMainTasklt.Value
'MsgBox s
sItem = Dic(s)
arr = Split(sItem, ",")
st = Val(arr(0))
ed = Val(arr(1))
iFirst = st + 1
iLast = st + ed
If ed = 0 Then
MsgBox "no data!!"
Exit Sub
End If
For i = iFirst To iLast
n = n + 1
ReDim Preserve vR(1 To 5, 1 To n)
For j = 0 To UBound(vC)
vR(j + 1, n) = vDB(i, vC(j))
Next j
Next i
With ListBox2
.ColumnCount = 5
.ColumnWidths = "50;150;50;60;60"
.BoundColumn = 2
.Column = vR
End With
End Sub
Result Image
When you click the "KICKOFF" , Show kickoff related data in listbox2.
Here is my current output that my VBscript is generating.
ID DESCRIPTION 1 RECURSIVE_ANALYSIS
CM-1 xxxxxxxxxxxx Issue A
Sub issue a
Sub issue b
Sub issue c
CM-2 yyyyyyyyyyy Issue B
Sub issue a
Sub issue b
This is following VBA code which i have designed for getting the output
Sub CellSplitter1()
Dim Temp As Variant
Dim CText As String
Dim J As Integer
Dim K As Integer
Dim L As Integer
Dim iColumn As Integer
Dim lNumCols As Long
Dim lNumRows As Long
Dim wksNew As Worksheet
Dim wksSource As Worksheet
Dim iTargetRow As Integer
iColumn = 3
Set wksSource = ActiveSheet
Set wksNew = Worksheets.Add
iTargetRow = 0
With wksSource
lNumCols = .Range("IV1").End(xlToLeft).Column
lNumRows = .Range("A65536").End(xlUp).Row
For J = 1 To lNumRows
CText = .Cells(J, iColumn).Value
Temp = Split(CText, Chr(10))
For K = 0 To UBound(Temp)
iTargetRow = iTargetRow + 1
For L = 1 To lNumCols
If L <> iColumn Then
wksNew.Cells(iTargetRow, L) _
= .Cells(J, L)
Else
wksNew.Cells(iTargetRow, L) _
= Temp(K)
End If
Next L
Next K
Next J
End With
End Sub
Here is my expected output
ID DESCRIPTION 1 RECURSIVE_ANALYSIS Issues
CM-1 xxxxxxxxxxxx Issue A Sub issue a
Sub issue b
Sub issue c
CM-2 yyyyyyyyyyy Issue B Sub issue a
Sub issue b
So, can someone help me to figure out to get the expected output.
Any help will be much appreciated.
Thank you
it seems you didn't show the whole story, so here's a guessing:
after your code place the following
With wksNew' reference 'wksNew' sheet
With .Range(.Cells(1, iColumn), .Cells(iTargetRow, iColumn)) ' reference its 'iColumn' column range from row 1 down to its last not empty one
.Insert 'insert a new column before referenced range. now the currently referenced range is one column right shifted (i.e. its in the 4th column of referenced sheet)
.Offset(, -1).Value = .Value ' copy values from referenced range one column to the left (i.e. in the newly created column)
.Offset(, -1).Replace "Sub issue*", "", lookat:=xlWhole 'clear the newly created range cells containing "Sub issue..." (hence, there remains cells with "Issue .." only)
.Replace "Issue *", "", lookat:=xlWhole 'clear the currently referenced range (i.e the one in 4th column) cells containing "Issue..." (hence, there remains cells with "Sub issue .." only)
End With
.Columns.AutoFit 'adjust your columns width
End With
Using Variant array is more simple.
Sub test()
Dim r As Long, c As Integer
Dim j As Integer
Dim k As Integer
Dim wksNew As Worksheet
Dim wksSource As Worksheet
Dim vDB, vSplit, vR()
Set wksSource = ActiveSheet
Set wksNew = Worksheets.Add
With wksSource
c = .Range("IV1").End(xlToLeft).Column
r = .Range("A65536").End(xlUp).Row
vDB = .Range("a1", .Cells(r, c))
For i = 1 To r
vSplit = Split(vDB(i, c), Chr(10))
For k = 1 To UBound(vSplit)
n = n + 1
ReDim Preserve vR(1 To c + 1, 1 To n)
If k = 1 Then
For j = 1 To c - 1
vR(j, n) = vDB(i, j)
Next j
vR(c, n) = vSplit(k - 1)
vR(c + 1, n) = vSplit(k)
Else
vR(c + 1, n) = vSplit(k)
End If
Next k
Next i
End With
Range("a1").Resize(1, c + 1) = Array("ID", "DESCRIPTION 1", "RECURSIVE_ANALYSIS", "Issues")
Range("a2").Resize(n, c + 1) = WorksheetFunction.Transpose(vR)
End Sub
Here is the sample of my current output which the VBscript code is generating.
[https://i.stack.imgur.com/kMpih.png] [1]:
Here is the sample of my expected output
[[1]: https://i.stack.imgur.com/StBqx.png]
Please let me know your suggestions.
Thank you
I am trying to assign values to column z using an array but I am not getting desire results. I am testing to assign cell Z1 = A, cell Z2 = B, cell Z3 = C
Right now my codes assign all 3 cells to C. I have posted my desire results below.
Sub test()
Dim ws1 As Worksheet
Dim i, j As Long
Dim v As Variant
Set ws1 = Worksheets("Sheet1")
With ws1
v = Array("A", "B", "C")
For i = LBound(v) To UBound(v)
For j = 1 To 3
Cells(j, 26).Value = v(i)
Next j
Next i
End With
End Sub
You can set option base 1 so use valid row references when writing values out (if array lbound was 0 you wouldn't be able to use .Cells(0, 26) = v(0) as no row 0 in the sheet.
Option Base: Used at module level to declare the default lower bound for array subscripts. Default is base 0.
Using Base 1 means can access all array elements and use same incremental variable for sheet and array i.e. can use just one long variable i.
Option Base 1
Sub test()
Dim ws1 As Worksheet
Dim i Long
Dim v As Variant
Set ws1 = Worksheets("Sheet1")
v = Array("A", "B", "C")
With ws1
For i = LBound(v) To UBound(v)
.Cells(i, 26) = v(i)
Next i
End With
End Sub
To learn how to read and write 1D or 2D VBA arrays into cells look at the code below:
Public Sub TestArrayReadAndWrite()
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
' Set a 1D array in VBA
' Write the array to cells
Dim v() As Variant
v = Array("A", "B", "C")
ws.Range("A1").Resize(3, 1).Value = WorksheetFunction.Transpose(v)
ws.Range("A5").Resize(1, 3).Value = v
' Set a 3×3 array in VBA
' Write the array to cells
Dim a() As Variant
ReDim a(1 To 3, 1 To 3)
a(1, 1) = "A11": a(1, 2) = "A12": a(1, 3) = "A13"
a(2, 1) = "A21": a(2, 2) = "A22": a(2, 3) = "A13"
a(3, 1) = "A31": a(3, 2) = "A32": a(3, 3) = "A13"
ws.Range("C1").Resize(3, 3).Value = a
' Read Array 100×1 array of cells
' Modify the array by doubling the values
' Write the array back to the next column over
Dim b() As Variant, i As Long
b = ws.Range("G1").Resize(100, 1).Value
For i = 1 To 100
b(i, 1) = 2 * b(i, 1)
Next i
ws.Range("G1").Offset(0, 1).Resize(100, 1).Value = b
End Sub
And the result:
It is a lot faster and concise to write entire arrays with one command by assigning to Range().Resize(n,m).Value = x then to loop through all the values and set them one at a time.
Try this
Sub test()
Dim ws1 As Worksheet
Dim i, j As Long
Dim v As Variant
Set ws1 = Worksheets("Sheet1")
With ws1
v = Array("A", "B", "C")
For i = LBound(v) To UBound(v)
For j = 1 To 3
Cells(j, 26).Value = v(j - 1)
Next j
Next i
End With
End Sub
What about this simple code.
Private Sub cmdFill_Click()
Dim i As Integer
For i = 1 To 26
Cells(i, 26).Value = Chr(64 + i)
Next i
End Sub
You can adjust 26 if you need only 3.
I'm trying to remove the blank records from a combobox with two lists.
This is my code:
Private Sub UserForm_Initialize()
Dim N As Range
Dim LastRow As Integer
Dim ws As Worksheet
PREST.ColumnCount = 2
Set ws = Worksheets("L_Location")
LastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Dim i, j As Integer
Dim location(2 To 100, 1 To 2) As String
For j = 1 To 2
For i = 2 To LastRow
If ws.Cells(i, j).Value <> vbNullString Then
location(i, j) = ws.Cells(i, j).Value
End If
Next i
Next j
PREST.List = location
End Sub
I don't know what I'm doing wrong.
You are having blanks because your 2D array is already sized with 100 rows. A simple workaround would be to first count the non-empty rows, then dimension the Array accordingly.
Dim location() As String
Dim count As Long
count = Range("A2:A" & LastRow).SpecialCells(xlCellTypeConstants).Cells.count
ReDim location(1 To count, 1 To 2)
'then continue from here to fill the array
This code will fill the combobox with your range value then will delete any empty item:
Private Sub UserForm_Initialize()
Dim LastRow As Long
Dim ws As Worksheet
PREST.ColumnCount = 2
Set ws = Worksheets("L_Location")
LastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Dim i As Long ', j As Integer
PREST.List = ws.Range("a1:b" & LastRow).Value
For i = PREST.ListCount - 1 To 0 Step -1
If PREST.List(i) = "" Then PREST.RemoveItem i
Next
End Sub
I tried this :
Dim location() As String
ReDim location(LastRow - 2, 1)
For j = 0 To 1
For i = 0 To LastRow - 2
If ws.Cells(i + 2, j + 1).Value <> vbNullString And ws.Cells(i + 2, j + 1).Value <> "" Then
location(i, j) = ws.Cells(i + 2, j + 1).Value
End If
Next i
Next j
PREST.List = location
which seems to work but i guess its gonna give me an error if the list is empty (lastrow = 1)
Since you say that any two cells on the same row are both either blank or with values, then you could go like follows:
Dim cell As Range
Dim i As Long, j As Long
PREST.ColumnCount = 2
With Worksheets("L_Location") '<--| reference your worksheet
With .Range("A2", .Cells(.Rows.Count,1).End(xlUp)).SpecialCells(xlCellTypeConstants) '<--| reference its column A not empty cells from row 1 down to last not empty one
Dim location(1 To .Count, 1 To 2) As String '<--| size your array rows number to that of referenced cells
For Each cell In .Cells '<--| loop through referenced cells
i = i + 1 '<--| update array row index
For j = 1 To 2 '<--| loop through array columns
location(i, j) = cell.Offset(j -1).Value '<--| fill array
Next j
Next cell
End With
End With
PREST.List = location
I've got a range in a text format containing values and numbers. I am trying to assign the numbers only to an array and then I will assign the text values to another array without having to loop through the range. However, this code says - type mismatch?
Sub Igra()
Dim Arr() As Variant
'convert the range values from text to general
Sheets("Sheet1").Range("R32:W32").NumberFormat = "General"
Sheets("Sheet1").Range("R32:W32").Value = Sheets("Sheet1").Range("R32:W32").Value
' assign only the numbers to the array
Arr = Sheets("Sheet1").Range("R32:W32").SpecialCells(xlCellTypeConstants, xlNumbers).Value
End Sub
This should work then
Dim Arr() As Variant
Sheets("Sheet1").Range("R32:W32").SpecialCells(xlCellTypeConstants, xlNumbers).Copy
Sheets("Sheet1").Range("A1").PasteSpecial xlValues
Arr = Range(Range("A1"), Range("A1").End(xlToRight))
Dim R As Long
Dim C As Long
For R = 1 To UBound(Arr, 1) ' First array dimension is rows.
For C = 1 To UBound(Arr, 2) ' Second array dimension is columns.
MsgBox Arr(R, C)
Next C
Next R
Try this
Sub Sample()
Dim ws As Worksheet
Dim Arr() As Variant
Dim rng As Range, cl As Range
Dim n As Long, i As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
Set rng = ws.Range("R32:W32")
n = Application.WorksheetFunction.Count(rng)
If n = 0 Then Exit Sub
ReDim Arr(1 To n)
i = 1
For Each cl In rng
If IsNumeric(cl.Value) Then
Arr(i) = cl.Value
i = i + 1
End If
Next cl
'~~> Only for demonstration purpose
For i = 1 To n
Debug.Print Arr(i)
Next i
End Sub