I have a spreadsheet like this, and I would like to have a function that returns the list of row numbers non-empty cells in column B. In this case, it should return "2, 3, 4, 5, 8, 9, 10, 11, 12, 13, 14, 15, 16, 18, 20, 21, 22, 23, 25, 26)
How do I do this in VBA?
Function GetEmptyCount()
Dim arr(), x&, cell
With Range("B1:B" & Cells(Rows.Count - 1, "B").End(xlUp).Row)
For Each cell In .SpecialCells(xlCellTypeBlanks).Cells
x = x + 1
ReDim Preserve arr(1 To x)
arr(x) = cell.Row
Next
End With
GetEmptyCount = arr
End Function
Sub Test()
Dim x, c
x = GetEmptyCount()
For Each c In x: MsgBox c: Next
End Sub
You can check the length of the cell value something like
IF(Length(Cell) > 0 THEN
// Include the row
ELSE
// skip the row
Related
A really basic question I m afraid:
How do I use a value as any part of an array?
Sub test()
Dim x As Variant
x = Array(1, 2, 3, 8, 9, 10, 1585)
If InStr(Cells(1,1).Value, x) Then
MsgBox "OK"
End If
End Sub
In this code I am trying to check if the cell contains any value from the array
You can use Match and check whether a number is returned (which means the value is found in the array).
Sub test()
Dim x As Variant
x = Array(1, 2, 3, 8, 9, 10, 1585)
If IsNumeric(Application.Match(Cells(1, 1).Value, x, 0)) Then
MsgBox "OK"
End If
End Sub
Alternatively, if it doesn't have to be an array one could simply use a string as such:
Sub test()
Dim arrayString As String
arrayString = "1, 2, 3, 8, 9, 10, 1585"
If InStr(1, arrayString, Cells(1, 1), vbTextCompare) > 0 Then
MsgBox "OK"
End If
End Sub
there I have an excel VBA code that retrieves its records from an external file by month and set it according to the column heading.
However, i have an error in of application-defined or object-defined error in of the line .Range("A6").Resize(n, 23) = b
does anyone know why
code:
Sub zz()
Dim arr, c, b(), n&
Application.ScreenUpdating = False
Worksheets("Sheet2").Range("A6").AutoFilter
Workbooks.Open "C:\Users\sophia.tan\Desktop\MasterPlanData.xlsx", 0, 1
arr = Sheets("Excel").UsedRange
ActiveWorkbook.Close 0
c = Array(0, 2, 13, 14, 7, 8, 11, 1, 9, 10, 16, 17, 20, 22, 15, 30, 27, 28, 29, 3, 4, 30)
d = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23)
ReDim b(1 To UBound(arr), 1 To 23)
For i = 2 To UBound(arr)
If arr(i, 12) >= DateSerial(Year:=2017, Month:=11, Day:=1) And arr(i, 12) <= DateSerial(Year:=2017, Month:=11, Day:=31) Then
n = n + 1
For j = 1 To UBound(c)
b(n, d(j)) = arr(i, c(j))
Next
End If
Next
With Worksheets("Sheet2")
.Range("A6:T" & Rows.Count).CurrentRegion.AutoFilter field:=1, Criteria1:="<>OFM"
.Range("A6:T" & Rows.Count).CurrentRegion.SpecialCells(xlCellTypeVisible).AutoFilter field:=13, Criteria1:="<>Collar & Cuff"
.Range("A6:T" & Rows.Count).CurrentRegion.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.Range("A6").Resize(n, 23) = b
.Range("A6").CurrentRegion.Sort key1:=Range("G6"), order1:=xlAscending, Header:=xlYes
.Range("A6").Select
End With
Application.ScreenUpdating = 1
End Sub
Your determination on n is subjective to the If statement. However, any unfilled values in the 'rows' of b will be vbnullstrings and will produce truly blank cells.
.Range("A6").Resize(ubound(b, 1), ubound(b, 2)) = b
Alternately,
For i = 2 To UBound(arr)
If arr(i, 12) >= DateSerial(Year:=2017, Month:=11, Day:=1) And arr(i, 12) <= DateSerial(Year:=2017, Month:=11, Day:=31) Then
n = n + 1
For j = 1 To UBound(c)
b(n, d(j)) = arr(i, c(j))
Next
End If
Next
b = application.transpose(b)
redim preserve b(lbound(b, 1) to ubound(b, 1), lbound(b, 2) to n)
b = application.transpose(b)
.Range("A6").Resize(n, 23) = b
You can only adjust the last rank of an array with ReDim when using the preserve parameter.
Try
.Range("A6").Resize(n, 23).Value = b
I have a 2d array holding values like the following:
array - JK(K, NC)
"K" Stores Total No of Items
"NC" Stores Items
I need to remove the duplicates From "NC"
and also update "K" (i.e the total items) after removing the duplicates.
4 - 5, 6, 7, 5
6 - 7, 6, 9, 10, 11, 7
4 - 8, 7, 15, 8
9 - 12, 15, 16, 12, 17, 18, 19, 20, 16
3 - 26, 27, 26
3 - 20, 19, 20
6 - 21, 33, 33, 34, 35, 21
8 - 19, 33, 34, 18, 38, 39, 40, 34
5 - 39, 40, 38, 43, 40
6 - 41, 44, 44, 45, 46, 41
3 - 20, 19, 20
6 - 21, 33, 33, 34, 35, 21
8 - 19, 33, 34, 18, 38, 39, 40, 34
Here is a Solution based on the Entries and Code from #tigeravatar and #Jeeped with you could have find here on Stack overflow, so a big thanks to this guys.
Removing Duplicate values from a string in Visual Basic
and
Multidimensional Arrays with For Loops VBA
Sub Test()
Dim strArray(8, 1) As String
Dim newString As String
strArray(0, 0) = "4"
strArray(0, 1) = "5 6 7 5"
strArray(1, 0) = "6"
strArray(1, 1) = "7 6 9 10 11 7"
strArray(2, 0) = "4"
strArray(2, 1) = "8 7 15 8"
strArray(3, 0) = "9"
strArray(3, 1) = "12 15 16 12 17 18 19 20 16"
strArray(4, 0) = "4"
strArray(4, 1) = "5 6 7 5"
strArray(5, 0) = "6"
strArray(5, 1) = "7 6 9 10 11 7"
strArray(6, 0) = "9"
strArray(6, 1) = "12 15 16 12 17 18 19 20 16"
For i = 0 To UBound(strArray, 1)
newString = DeDupeString(strArray(i, 1), " ")
strArray(i, 0) = UBound(Split(newString, " ")) + 1
strArray(i, 1) = newString
Next i
End Sub
Function DeDupeString(ByVal sInput As String, Optional ByVal sDelimiter As String = ",") As String
Dim varSection As Variant
Dim sTemp As String
varSection = Split(sInput, sDelimiter)
For Each varSection In Split(sInput, sDelimiter)
If InStr(1, sDelimiter & sTemp & sDelimiter, sDelimiter & varSection & sDelimiter, vbTextCompare) = 0 Then
sTemp = sTemp & sDelimiter & varSection
End If
Next varSection
DeDupeString = Mid(sTemp, Len(sDelimiter) + 1)
End Function
You could use a function, something like this
Function RemoveDupes(strInput As String) As Variant()
' Uses Microsoft Scripting Runtime referece
Dim arrSplit() As String
Dim lngCounter As Long
Dim dicDupeCheck As New Scripting.dictionary
arrSplit = Split(strInput, Chr(32))
For lngCounter = 0 To UBound(arrSplit) - 1
If Not dicDupeCheck.Exists(arrSplit(lngCounter)) Then
dicDupeCheck.Add arrSplit(lngCounter), arrSplit(lngCounter)
End If
Next lngCounter
RemoveDupes = Array(dicDupeCheck.Count, Join(dicDupeCheck.Items(), " "))
Erase arrSplit
End Function
This will then be used as follows
RemoveDupes("12 15 16 12 17 18 19 20 16")(0) will give the count, and RemoveDupes("12 15 16 12 17 18 19 20 16")(1) will give the non-dupe output.
Or set an array to removedupes and use that, so arr=RemoveDupes("12 15 16 12 17 18 19 20 16") then OriginalArray(x)=arr(0) & " - " & arr(1)
This is my logic
arr(1,2,3,4,5,6,7,8,9)
arr1(3,4,5)
arr2(2,0)
arr3(6,7,45,8,3)
(arr,arr1)....-> True
(arr,arr2)....-> False
(arr,arr3)....-> False
using word VBA, how to find that the value in arr2 must present in arr? if one of the value in arr2 didn't match with arr then it should come out of the particular array(Example: arr2(0,9)) and then start checking with next array(arr3). I want to compare one arr with multiple arrays**(arr1,arr2,arr3)**. I tried the below mentioned logic.
For j = 1 To UBound(arr1)
For k = 1 To UBound(arr2)
If arr1(j) = arr2(k) Then
\\.......
End If
Next
Next
Is this what you had in mind?
Sub TestMatched()
Dim Arr() As Variant
Arr = Array(33, 4, 15)
Debug.Print Matched(Arr)
End Sub
Private Function Matched(Arr2() As Variant) As Long
Dim Arr1() As Variant
Dim i As Long
Arr1 = Array(1, 2, 3, 4, 5, 6, 7, 8, 9)
For i = LBound(Arr2) To UBound(Arr2)
If Not IsError(Application.Match(Arr2(i), Arr1, 0)) Then
Matched = Arr2(i)
Exit For
End If
Next i
End Function
So I have a string of numbers in excel, each number 1-2 digits but the separated by commas and there can a varying amount of numbers. eg:
eg:
A B C
9, 13, 42, 44 | 1, 18 | 24, 30, 61, 23, 30
I would like a macro which takes each line (eg 9, 13, 42, 44) and puts each number i a different cell in the same column - like this
9
13
42
44
Select the cells you wish to process and run this short macro:
Sub SplitThem()
Dim r As Range
For Each r In Selection
ary = Split(Replace(r.Value, " ", ""), ",")
i = 1
For Each a In ary
r.Offset(i, 0).Value = a
i = i + 1
Next a
Next r
End Sub
Each item falls in the same column as its parent list.
if you want to maintain "original" values:
Option Explicit
Sub SplitNumbers()
Dim cell As Range
For Each cell In Worksheets("mySheet").Rows(1).SpecialCells(xlCellTypeConstants) '<--| choose your row of interest
cell.Offset(1).Resize(UBound(Split(cell.Value, ", ")) + 1) = Application.Transpose(Split(cell.Value, ", "))
Next cell
End Sub
if you want to delete "original" values:
Option Explicit
Sub SplitNumbers2()
Dim cell As Range
For Each cell In Worksheets("mySheet").Rows(1).SpecialCells(xlCellTypeConstants) '<--| choose your row of interest
cell.Resize(UBound(Split(cell.Value, ", ")) + 1) = Application.Transpose(Split(cell.Value, ", "))
Next cell
End Sub
With your data in a series of cells in the first row like this,
Data before splitTranspose sub procedure
Run this quick sub procedure that utilizes VBA's Split function and the worksheet's TRANSPOSE function.
Sub splitTranspose()
Dim c As Long, vals As Variant
With Worksheets("Sheet1")
For c = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
If CBool(InStr(1, .Cells(1, c).Value2, Chr(44))) Then
vals = Split(Replace(.Cells(1, c).Value2, Chr(32), vbNullString), Chr(44))
.Cells(1, c).Resize(UBound(vals) + 1, 1) = _
Application.Transpose(vals)
End If
Next c
End With
End Sub
Your results should resemble the following,
Data after splitTranspose sub procedure