l am trying to collect and SUM data from a workbook.
The data I need is calculated from cells in one sheet of the workbook. I will display the result with "value only format".
How can I shorten the code and make it run faster?
The workbook where I collect data is Test.xlsm and I have around 30 items.
Sub Test1()
'
' Test1 Macro
Dim Slaw150 As Variant
Dim Slaw200 As Variant
Dim Slaw300 As Variant
Dim Slaw400 As Variant
Slaw150 = "=SUM('[Test.xlsm]Test'!$CO$66:$CS$66,'[Test.xlsm]Test'!$CO$88:$CS$88,'[Test.xlsm]Test'!$CO$95:$CS$95)"
Slaw200 = "=SUM('[Test.xlsm]Test'!$CO$67:$CS$67,'[Test.xlsm]Test'!$CO$89:$CS$89,'[Test.xlsm]Test'!$CO$96:$CS$96)"
Slaw300 = "=SUM('[Test.xlsm]Test'!$CO$68:$CS$68,'[Test.xlsm]Test'!$CO$90:$CS$90,'[Test.xlsm]Test'!$CO$97:$CS$97)"
Slaw400 = "=SUM('[Test.xlsm]Test'!$CO$69:$CS$69,'[Test.xlsm]Test'!$CO$91:$CS$91,'[Test.xlsm]Test'!$CO$98:$CS$98)"
With Range("C42")
.Value = Slaw150
.Value = .Value
End With
With Range("C43")
.Value = Slaw200
.Value = .Value
End With
With Range("C44")
.Value = Slaw300
.Value = .Value
End With
End Sub
Please, test the next way:
Sub TestSUMM()
Dim sh As Worksheet, rngSUM As Range, arrSUM, i As Long
Set sh = Workbooks("Test.xlsm").Sheets("Test")
Set rngSUM = sh.Range("CO66:CS69,CO88:CS91,CO95:CS98") 'The whole discontinuous range
ReDim arrSUM(1 To 4, 1 To 1) 'ReDim the array to keep processing result
For i = 1 To rngSUM.rows.Count 'iterate between the discontinuous range rows and summarize them:
arrSUM(i, 1) = WorksheetFunction.Sum(rngSUM.rows(i))
Next i
sh.Range("I41").Resize(4).Value = arrSUM 'drop the array content at once
End Sub
Related
I am trying to pick a random value from a range of values and output this value in Cell E6.
Some of the cells are blank so I need to pick from a cell that contains a value.
The range of which the values to choose from is H127:1127.
Sub Generate()
Dim i As Double
Dim ws As Worksheet
Set ws = Sheets("Upstream-Overall")
For Each Cell In ws.Range("H127:H1127")
If ActiveCell.Value <> "" Then
Range("E6") = Random_Number = Application.WorksheetFunction.RandBetween(0.1, 5)
End If
Next Cell
End Sub
Return the Number From a Random Cell
Sub Generate()
Const wsName As String = "Upstream-Overall"
Const sRangeAddress As String = "H127:H1127"
Const dCellAddress As String = "E6"
' Reference the worksheet in the workbook containing this code.
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets(wsName)
' Write the values from the first column of the range to an array.
Dim Data As Variant: Data = ws.Range(sRangeAddress).Columns(1).Value
Dim sr As Long, dr As Long
' Shift the numeric values (up) to the beginning of the array.
For sr = 1 To UBound(Data, 1)
If VarType(Data(sr, 1)) = 5 Then ' is a number
dr = dr + 1
Data(dr, 1) = Data(sr, 1)
'Else ' is not a number; do nothing
End If
Next sr
' Check if at least one number was found.
If dr = 0 Then
MsgBox "No numbers in the first column of the range.", vbCritical
Exit Sub
End If
' Write the number from a random element
' of the numeric part of the array to the cell.
ws.Range(dCellAddress).Value = Data(Int(dr * Rnd + 1), 1)
' Inform of success.
MsgBox "New random number generated.", vbInformation
End Sub
You could do something like this:
Sub Generate()
Dim ws As Worksheet, rng As Range, i As Long, v
Set ws = Sheets("Upstream-Overall")
Set rng = ws.Range("H127:H1127")
Do
i = Application.RandBetween(1, rng.Cells.Count)
v = rng.Cells(i).Value
Loop While Len(v) = 0 'loop until selected cell has a value
ws.Range("E6").Value = v
End Sub
(assuming the range will never be completely empty)
I have a column that has text in some cells and formulas in the others. When I'm trying to loop through an array to search for some values in the columns, I can't seem to reference the values as a result of formulas. For example, I'm trying to do conditional statements like If arr(i, 15) = "String" Then but String is the result of a Vlookup.
printing the entire array gives me the formulas, not the results
Sub test()
Dim ws As Worksheet
Dim arr As Variant
Set ws = ThisWorkbook.Worksheets("Sheet1")
arr = ws.Range("A1").CurrentRegion.Formula
For i = LBound(arr, 1) To UBound(arr, 1)
If Not IsError(arr(i, 15)) Then 'Some of the values are #NA
Debug.Print arr(i, 15)
End If
Next i
End Sub
If you only want to obtain value from cells formula not result in error, probably array may not suitable in such case, use For loop will achieve your expected input also. In my example, Range("E3) is not printed due to error, you can combine with lastrow for dynamic range:
I add version 2 here for using array looping, the outcome skip to print Range("E2") due to error, hope it help :)
Sub test()
Dim ws As Worksheet
Dim arr As Variant
Dim i As Long
Dim textValue As String
Set ws = ThisWorkbook.Worksheets("Sheet2")
arr = ws.Range("D1").CurrentRegion.Value
For i = LBound(arr) To UBound(arr)
textValue = CStr(arr(i, 2))
If InStr(textValue, "Error") <= 0 Then 'Some of the values are #NA
Debug.Print textValue
End If
Next i
End Sub
your code has an End If without if
To get the value of the formula, use Evaluate(formula), this line only work if send a formula as parameter, use on error resume next if is possible to sent errors, empty values or not formula values... Good Luck
Sub test()
Dim ws As Worksheet
Dim arr As Variant
Set ws = ThisWorkbook.Worksheets("Sheet1")
arr = ws.Range("A1").CurrentRegion.Formula
For i = LBound(arr, 1) To UBound(arr, 1)
On Error Resume Next
If Not IsError(arr(i, 15)) Then 'Some of the values are #
Debug.Print Evaluate(arr(i, 15))
'End If
End If
Next I
End Sub
I have a excel table looks like below:
Name task date1 date2 date3 date4
John t1 d1
Lucy t2
Mary t3 d2 d3
I want to remove the rows whose columns after 3rd column (i.e. from date1) are empty (e.g. Lucy in this example)
I found the below example, I think it is close but not sure how I can modify it by choosing the empty rows after 3rd column instead of the whole row.
Sub DeleteAllEmptyRows()
Dim LastRowIndex As Integer
Dim RowIndex As Integer
Dim UsedRng As Range
Set UsedRng = ActiveSheet.UsedRange
LastRowIndex = UsedRng.Row - 1 + UsedRng.Rows.Count
Application.ScreenUpdating = False
For RowIndex = LastRowIndex To 1 Step -1
If Application.CountA(Rows(RowIndex)) = 0 Then 'Some logic to add here to choose range
Rows(RowIndex).Delete
End If
Next RowIndex
Application.ScreenUpdating = True
End Sub
Any suggestions please? Thanks.
I think all you need is to first calculate the last column in the used range and then use it in the CountA statement inside the loop.
To calculate the last column, you could add the following lines right before the loop:
Dim LastColIndex As Integer: LastColIndex = UsedRng.Column - 1 + UsedRng.Columns.Count
The If statement would then need to look like something like this:
If WorksheetFunction.CountA(Range(Cells(RowIndex, 3), Cells(RowIndex, LastColIndex))) = 0 Then
This checks for non-empty values starting from the 3rd column in the current row.
The combined code would then look like this:
Sub DeleteAllEmptyRows()
Dim LastRowIndex As Integer
Dim RowIndex As Integer
Dim UsedRng As Range
Set UsedRng = ActiveSheet.UsedRange
LastRowIndex = UsedRng.Row - 1 + UsedRng.Rows.Count
Application.ScreenUpdating = False
Dim LastColIndex As Integer: LastColIndex = UsedRng.Column - 1 + UsedRng.Columns.Count
For RowIndex = LastRowIndex To 1 Step -1
If WorksheetFunction.CountA(Range(Cells(RowIndex, 3), Cells(RowIndex, LastColIndex))) = 0 Then
Rows(RowIndex).Delete
End If
Next RowIndex
Application.ScreenUpdating = True
End Sub
I would also change the For loop to count down to 2 instead of 1 to avoid the possibility of ever deleting the header row, but I guess that depends on your taste :)
In case of phantom values ...
Sometimes, cells have values that are invisible to the naked eye but are counted by Excel's COUNTA function, as when a cell has one or more spaces as its value. If those cases need to be accounted for, we can check each cell individually using the following VBA function:
Function IsBlankRange(ByRef rng As Range) As Boolean
'For faster processing, read in the entire range into a memory variable
' instead of reading in each cell value from Excel
Dim arr As Variant: arr = rng.Value
'If the range contains a single value, check it and exit
If Not IsArray(arr) Then 'With single-value ranges, arr will not be an array
IsBlankRange = Trim(arr & "") = ""
Exit Function
End If
'If we are here, the range contains an array of values,
' so we must loop through the array
'Assume the range is not blank
IsBlankRange = False
Dim arrLb1 As Long: arrLb1 = LBound(arr, 1)
Dim arrUb1 As Long: arrUb1 = UBound(arr, 1)
Dim arrLb2 As Long: arrLb2 = LBound(arr, 2)
Dim arrUb2 As Long: arrUb2 = UBound(arr, 2)
Dim i As Long, j As Long
For i = arrLb1 To arrUb1
For j = arrLb2 To arrUb2
'Return false (the value assumed above) on the first non-blank value
If Trim(arr(i, j) & "") <> "" Then Exit Function
Next
Next
'If we are here, no non-blank value was encountered, so the range is blank
IsBlankRange = True
End Function
This function can be used to change the If WorksheetFunction.CountA(...) = 0 line to
If IsBlankRange(Range(Cells(RowIndex, 3), Cells(RowIndex, LastColIndex))) Then
In short, the new procedure would look like this:
Sub DeleteAllEmptyRows()
Dim LastRowIndex As Integer
Dim RowIndex As Integer
Dim UsedRng As Range
Set UsedRng = ActiveSheet.UsedRange
LastRowIndex = UsedRng.Row - 1 + UsedRng.Rows.Count
Application.ScreenUpdating = False
Dim LastColIndex As Integer: LastColIndex = UsedRng.Column - 1 + UsedRng.Columns.Count
For RowIndex = LastRowIndex To 1 Step -1
If IsBlankRange(Range(Cells(RowIndex, 3), Cells(RowIndex, LastColIndex))) Then
Rows(RowIndex).Delete
End If
Next RowIndex
Application.ScreenUpdating = True
End Sub
Naturally, the new IsBlankRange function would need to be added as well (below the DeleteAllEmptyRows code, probably). The function can be made private to the module if it will never be used anywhere else.
But, if you can use CONCAT ...
The IsBlankRange function can be simplified if you have Excel 2019 and can use the new CONCAT function, which can be applied to a range:
Function IsBlankRange(ByRef rng As Range) As Boolean
IsBlankRange = Trim(WorksheetFunction.Concat(rng) & "") = ""
End Function
{The CONCAT function is explained at https://www.excelfunctions.net/excel-concat-function.html}
Instead of using an IsBlankRange function, CONCAT could also be used directly in the If statement inside the For loop:
If Trim(WorksheetFunction.Concat(Range(Cells(RowIndex, 3), Cells(RowIndex, LastColIndex))) & "") = "" Then
However, I believe that leaving the range evaluation in a separate function makes it easier to customise depending on the version of Excel being used, and it makes the If statement easier to read.
I need your help moving data from a listbox to a worksheet.
This listbox contains 14 columns. How can I copy the rows from the listbox to the worksheet?
Sub Post ()
Dim arr
Dim cnt As Integer
cnt = ListBox1.ListCount
arr = ListBox1.List
With Sheets("DATABASE").ListObjects(1)
.ListRows.Add
.DataBodyRange.Cells(.ListRows.Count, 1).Resize(cnt, 14) = arr
End With
ListBox1.clear
End Sub
***************** Update 15-01-2019 17:30 **********************
i found this code but it moves 1 line down as pic below
Private Sub CommandButton2_Click()
Dim i As Long
For i = 0 To ListBox1.ListCount
For x = 1 To 14
Sheets("Database").Range("B2").End(xlDown).Offset(i + 1, x - 1) =
ListBox1.List(i, x - 1) 'ListBoxl.List(i, x)
Next x
Next i
End Sub
Pic
It is not very clear how you set the target cell, anyhow you can try this (following the logic of your sample):
Dim Trg as Range
With Sheets("DATABASE").ListObjects(1)
Set Trg = .DataBodyRange.Cells(.ListRows.Count, 1)
End With
Trg.Resize(UBound(arr, 1), UBound(arr, 2)) = arr
It is easy to paste the content of an array to a range if you can specify the top left cell and the bottom right cell of the target range in advance, so you can say
Range("B8:E16") = arr
If you only know the the top left cell and want to set the size of the target range dynamically, use .Resize like this:
Range("B8").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
NB: if the target range is smaller than the array then only that amount of data is copied, the rest is omitted.
finally i found a code that solved my problem
Private Sub CommandButton1_Click()
Dim lngItem As Long
For lngItem = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(lngItem) Then
With Sheets(1) '< qualify sheet here
.Cells(.Rows.Count, "B").End(xlUp).Offset(1).Value =
ListBox1.List(lngItem, 1)
.Cells(.Rows.Count, "C").End(xlUp).Offset(1).Value =
ListBox1.List(lngItem, 2)
End With
End If
Next lngItem
'Unload Me
End Sub
I have data in Sheet2 as like below.
Actual Data
Then I manually apply filer to those data which looks like...
Filtered Data
I have a user form (UserForm1) and a list box (ListBox1) in the form. Also have a command button cmdFilteredData. So, I want to fill the listbox with filtered data only. I make below codes but it gives Type mismatch error.
Private Sub cmdFilteredData_Click()
Dim FilteredRange As Range
Set FilteredRange = Sheet2.Range("A1:C5").Rows.SpecialCells(xlCellTypeVisible)
With Me.ListBox1
.ColumnCount = 3
.MultiSelect = fmMultiSelectExtended
.RowSource = FilteredRange
End With
End Sub
Any help is hearty appreciated.
Since you are trying to populate the ListBox1 with values from filtered range, you have blank rows in the middle, this "messes" up the ListBox.
Instead, you can copy>>Paste the value to columns on the right (or another worksheet), use an array to populate these values, and then populate the ListBox1 with the array.
Code
Private Sub cmdFilteredData_Click()
Dim FilteredRange As Range
Dim myArr As Variant
Set FilteredRange = ThisWorkbook.Sheets("Sheet8").Range("A1:C5").SpecialCells(xlCellTypeVisible)
' copy filtered range to the columns on the right (if you want, you can add a "Dummy" sheet), to have the range continous
FilteredRange.Copy Range("Z1")
' populae the array with new range values (without blank rows in the middle)
myArr = Range("Z1").CurrentRegion
With Me.ListBox1
.ColumnCount = 3
.MultiSelect = fmMultiSelectExtended
.List = (myArr)
End With
End Sub
Alternative Function to - unreliable - SpecialCells(xlCellTypeVisible)
This answer intends to complete Shai Rado's appreciated solution, not to correct it.
Testing the above solution, however showed that using SpecialCells(xlCellTypeVisible) and/or reference to CurrentRegion might result in problems (even within OP's small range).
A possible work around function (esp. for udfs) is presented at SpecialCells(xlCellTypeVisible) not working in UDF.
Private Function VisibleCells(rng As Range) As Range
' Site: https://stackoverflow.com/questions/43234354/specialcellsxlcelltypevisible-not-working-in-udf
' Note: as proposed by CalumDA
Dim r As Range
For Each r In rng
If r.EntireRow.Hidden = False Then
If VisibleCells Is Nothing Then
Set VisibleCells = r
Else
Set VisibleCells = Union(VisibleCells, r)
End If
End If
Next r
End Function
Shai Rado's solution slightly modified (cf. above notes)
In any case the target range has to be cleared before copying and then better referenced without CurrentRegion, so that you get the wanted items only. These changes worked for me.
Option Explicit
Private Sub cmdFilteredData_Click()
Dim ws As Worksheet
Dim sRng As String
Dim FilteredRange As Range
Dim myArr As Variant
Dim n As Long
Set ws = ThisWorkbook.Worksheets("Filtered")
n = ws.Range("A" & ws.Rows.Count).End(xlUp).Row ' get last row
sRng = "A1:C" & n
' Set FilteredRange = ws.Range(sRng).SpecialCells(xlCellTypeVisible) ' << not reliable
Set FilteredRange = VisibleCells(ws.Range(sRng)) ' <<<< possible ALTERNATIVE
' clear target range in order to allow correct array fillings later !
ws.Range("Z:AAB").Value = ""
' copy filtered range to the columns on the right
FilteredRange.Copy ws.Range("Z1")
' populate the array with new range values (without blank rows in the middle)
' myArr = ws.Range("Z1").CurrentRegion ' sometimes unreliable, too
myArr = ws.Range("Z1:AAB" & ws.Range("Z" & ws.Rows.Count).End(xlUp).Row) ' <<< better than CurrentRegion
With Me.ListBox1
.ColumnCount = 3
.MultiSelect = fmMultiSelectExtended
.List = (myArr)
End With
End Sub
Links mentioned in cited post:
Microsoft - udf not working
ExcelForum - xlCelltypeVisible not working
MrExcel - SpecialCells not working
I was searching a lot for that but I couldn't fine any elegant solution for doing it without pasting data in the sheet. So I create my own function to convert visible cells of range into an array.
Maybe it's not the smartest way, but works just fine an quite fast.
Function createArrFromRng(rng As Range)
Dim sCellValues() As Variant
Dim col, row, colCount, RowCount As Integer
col = 0
row = 0
colCount = 0
RowCount = 0
On Error GoTo theEnd
Set rng = rng.SpecialCells(xlCellTypeVisible)
'get the columns and rows size
For Each cell In rng
If col < cell.Column Then
colCount = colCount + 1
Else
colCount = 1
End If
col = cell.Column
If row < cell.row Then
RowCount = RowCount + 1
End If
row = cell.row
Next cell
'set the array size
ReDim Preserve sCellValues(RowCount - 1, colCount - 1)
col = 0
row = 0
colCount = 0
RowCount = 0
'get the values and add to the array
For Each cell In rng
If col < cell.Column Then
colCount = colCount + 1
Else
colCount = 1
End If
col = cell.Column
'Debug.Print colCount
If row < cell.row Then
RowCount = RowCount + 1
End If
row = cell.row
sCellValues(RowCount - 1, colCount - 1) = cell.value
Next cell
theEnd:
createArrFromRng = sCellValues
End Function