Trying to only round the numbers in column 4 but this macro code isn't working properly. Maybe there is another way to word it.
It is using a selection for the range but I think there has to be another way of putting this.
Thank you.
Sub RoundNumbersInColumn()
Dim rowMax As Long
Dim rowStart As Long
Dim colNo As Long
Dim aCell As Cell
Dim aTable As Table
Dim tabPos As Single
Dim k As Long
Dim aValue As Single
Dim formatStr As String
Dim s As String
' set format to number of decimal places to round to
formatStr = "#0.0000"
Set aTable = Selection.Tables(1)
rowMax = aTable.Rows.Count
Set aCell = Selection.Cells(1)
rowStart = aCell.RowIndex
colNo = aCell.ColumnIndex
tabPos = -1
If aCell.Range.ParagraphFormat.TabStops.Count > 0 Then
If aCell.Range.ParagraphFormat.TabStops.Item(1).Alignment = wdAlignTabDecimal Then _
tabPos = aCell.Range.ParagraphFormat.TabStops.Item(1).Position
End If
For k = rowStart To rowMax
Set aCell = aTable.Cell(Row:=k, Column:=4)
s = aCell.Range.Text
s = Left(s, Len(s) - 1)
If IsNumeric(s) Then
aValue = Val(s)
With aCell.Range.ParagraphFormat.TabStops
.ClearAll
.Add Position:=tabPos, Alignment:=wdAlignParagraphCenter
End With
aCell.Range.Text = Format(Str(aValue), formatStr)
End If
Next k
End Sub
Remove the underline after Then in line 26. Then add an End If to close the first If statement. Like so:
If aCell.Range.ParagraphFormat.TabStops.Count > 0 Then
If aCell.Range.ParagraphFormat.TabStops.item(1).Alignment = wdAlignTabDecimal Then
tabPos = aCell.Range.ParagraphFormat.TabStops.item(1).Position
End If
End If
Related
I am trying to count the number of occurrence for this phrase "SMM:" in each row in column AJ starting from row 2 and then assign the assign the value for each row to column BL starting from row 2.
Sub calculateamlp()
Dim charactercount As Integer
Dim rangeAG As Range
Dim cellCheck As Range
Dim f As Integer
f = 2
Worksheets("pptsr").Activate
Set rangeAG2 = Range("BL2", Range("BL2").End(xlDown))
Set rangeAG = Range("Aj2", Range("Aj2").End(xlDown))
For Each cellCheck In rangeAG
charactercount = Len(cellCheck) - Len(WorksheetFunction.Substitute(cellCheck, ":", ""))
Worksheets("pptsr").Range("BL2" & f).Value = charactercount
f = f + 1
Next cellCheck
End Sub
This function get the count by counting the number of elements in Splitting the String using the with the Substring.
Function getStrOccurenceCount(Text As String, SubString As String)
getStrOccurenceCount = UBound(Split(Text, SubString))
End Function
You could modify your code like this
Worksheets("pptsr").Range("BL2" & f).Value = getStrOccurenceCount(cellCheck.Text, "SMM:")
Here is how you could use the getStrOccurenceCount with arrays to improve your efficiency.
Sub calculateamlp2()
Const SUBSTRING As String = "SMM:"
Dim rangeAG As Range
Dim data As Variant
Dim x As Long
Set rangeAG = Range("AJ2", Range("AJ2").End(xlDown))
data = rangeAG.Value
For x = 1 To UBound(data)
data(x, 1) = getStrOccurenceCount(CStr(data(x, 1)), SUBSTRING)
Next
rangeAG.EntireRow.Columns("BL").Value = data
End Sub
Demo: Sample data 999,999 rows, execution time 0.9375 Seconds:
For exact match you should use "vbBinaryCompare". If you want to match "smm:" with "SMM:" then you should use "vbTextCompare". Try this:
Sub calculateamlp()
Dim count As Long, i As Long, j As Long, rw As Long
Dim ws As Worksheet
Set ws = Worksheets("pptsr")
With ws
rw = .Range("AJ" & .Rows.count).End(xlUp).Row
For i = 2 To rw
For j = 1 To Len(.Cells(i, "AJ"))
If InStr(j, .Cells(i, "AJ"), "SMM:", vbTextCompare) Then
count = count + 1
j = InStr(j, .Cells(i, "AJ"), "SMM:", vbTextCompare)
End If
Next j
.Cells(i, "BL") = count
count = 0
Next
End With
End Sub
I have a spreadsheet that has values for more than one month, so I am trying to first find the value based on a value in the wsRevFile worksheet and then ensure that this is the value from last month. When I use the following code, I get a "invalid number of arguments" error.
Sub RevLookup(wsMvFile As Worksheet, wsRevOld As Worksheet, wsNewRev As Worksheet, _
rowCount As Integer, workCol As String, _
srcCol1 As Integer, srcCol2 As Integer)
Dim vrw As Variant, i As Long
For i = 2 To rowCount
vrw = Application.Match(wsRevFile.Range("A" & i), wsNewRev.Columns(2), Format(DateSerial(Year(Date), Month(Date), 0), "mm/dd/yyyy"), wsNewRev.Columns(1), 0)
If IsError(vrw) Then
vrw = Application.Match(wsRevFile.Range("A" & i), wsRevOld.Columns(1), 0)
If Not IsError(vrw) Then _
wsRevFile.Range(workCol & i) = Application.Index(wsRevOld.Columns(srcCol1), vrw)
Else
wsRevFile.Range(workCol & i) = Application.Index(wsNewRev.Columns(srcCol2), vrw, 1)
End If
Next i
End Sub
I am assuming this has to do with the way I assigned the Application Match function, because the formula without this part works for other columns. Any ideas on how I could get this to work?
Thanks for your help!
Try ajusting the variables of the following procedure, as I didn't figure out your input and output data:
Sub Main()
Dim SearchValue As Variant
Dim SearchColumn As Range
Dim ReturnColumn As Range
Dim ResultRows As Collection
Dim LastDate As Variant 'Date?
Dim iRow As Variant
SearchValue = 10 '<-- change to suit
Set SearchColumn = wsNewRev.Range("B1:B10")
Set ReturnColumn = wsNewRev.Range("C1:C10") '<-- change to suit
Set ResultRows = GetLoopRows(SearchColumn, SearchValue)
For Each iRow In ResultRows
If LastDate < ReturnColumn(iRow) Then
LastDate = ReturnColumn(iRow)
End If
Next iRow
Debug.Print LastDate
End Sub
Function GetLoopRows(ParamArray pParameters() As Variant) As Collection
'Obtém limites de laços com levando em conta condições
'[vetor1], [valor1], [vetor2], [valor2], ...
Dim iCondition As Long
Dim i As Variant
Dim iRow As Variant
Dim Result As Collection
Dim NumConditions As Long
Dim SearchCollection As Collection
Dim ArraysCollection As Collection
Dim iArray As Variant
NumConditions = (UBound(pParameters) - LBound(pParameters) + 1) / 2
Set ArraysCollection = New Collection
Set SearchCollection = New Collection
For i = LBound(pParameters) To UBound(pParameters) Step 2
ArraysCollection.Add pParameters(i + 0).Value2
SearchCollection.Add pParameters(i + 1)
Next i
Set Result = New Collection
For iRow = LBound(ArraysCollection(1)) To UBound(ArraysCollection(1))
For iCondition = 1 To NumConditions
If ArraysCollection(iCondition)(iRow, 1) <> SearchCollection(iCondition) Then GoTo Continue
Next iCondition
Result.Add CLng(iRow)
Continue:
Next iRow
Quit:
Set GetLoopRows = Result
End Function
I have to search column B for a certain string and return a specific range of cells for all occurrences of the string in the file. I have code which searches and finds all occurrences of the string but have difficulty with copying into a new sheet the specific range of cells between Path and Owner. The catch is that the row numbers between Path and Owner are dynamic.
Excel structure
(including expected results for search string Kevin).
Macro
Sub FindString()
Dim intS As Integer
Dim rngC As Range
Dim strToFind As String, FirstAddress As String
Dim wSht As Worksheet
Application.ScreenUpdating = True
intS = 1
Set wSht = Worksheets("Search Results")
strToFind = Range("I3").Value 'This is where I obtain the string to be searched
With ActiveSheet.Range("B1:B999999")
Set rngC = .Find(what:=strToFind, LookAt:=xlPart)
If Not rngC Is Nothing Then
FirstAddress = rngC.Address
Do
(
'need help to find copy rows from column B based on values in column A
)
intS = intS + 1
Set rngC = .FindNext(rngC)
Loop While Not rngC Is Nothing And rngC.Address <> FirstAddress
End If
End With
Please help me or guide me as I'm a newbie to Excel.
This code will display the paths found (variable sPath), this is untested:
Sub FindString()
'Dim intS As Integer
Dim rngC As Range
Dim strToFind As String, FirstAddress As String
Dim wSht As Worksheet, lRowPath As Long, lRowOwner As Long, i As Long, sPath As String
'Application.ScreenUpdating = True
'intS = 1
Set wSht = Worksheets("Search Results")
strToFind = Range("I3").Value 'This is where I obtain the string to be searched
'With ActiveSheet.Range("B1:B999999")
With ActiveSheet.Range("B:B")
Set rngC = .Find(what:=strToFind, LookAt:=xlPart)
If Not rngC Is Nothing Then
FirstAddress = rngC.Address
Do
' Find the "Path:" above the found cell, note that offset too much is not handled: Cells(-1,1)
i = -1
Do Until InStr(1, rngC.Offset(i, -1).Value, "Path", vbTextCompare) > 0
i = i - 1
Loop
lRowPath = rngC.Row + i
' Find the Owner row above the found cell
i = -1
Do Until InStr(1, rngC.Offset(i, -1).Value, "Owner", vbTextCompare) > 0
i = i - 1
Loop
lRowOwner = rngC.Row + i
'need help to find copy rows from column B based on values in column A
sPath = ""
For i = lRowPath To lRowOwner - 1
sPath = sPath & ActiveSheet.Cells(i, "B").Value ' <-- Update
Next
Debug.Print "Searching " & strToFind; " --> " & sPath
'intS = intS + 1
Set rngC = .Find(what:=strToFind, After:=rngC, LookAt:=xlPart)
Loop Until rngC.Address = FirstAddress
End If
End With
End Sub
I suggest you load everything to memory first, then do your searches and manipulations.
You could use a user-defined type to store info about your paths:
Type PathPermissionsType
pth As String
owner As String
users As Dictionary
End Type
Note: to use Dictionary you need to go to Tools>References and set a checkmark next to Microsoft Scripting Runtime.
You can load all your info using something like this:
Function LoadPathPermissions() As PathPermissionsType()
Dim rngHeaders As Range
Dim rngData As Range
Dim iPath As Long
Dim nPath As Long
Dim iRow As Long
Dim nRow As Long
Dim vHeaders As Variant
Dim vData As Variant
Dim pathPermissions() As PathPermissionsType
Set rngHeaders = Range("A1:A12") 'or wherever
Set rngData = rngHeaders.Offset(0, 1)
'Load everything to arrays
vHeaders = rngHeaders.Value
vData = rngData.Value
nRow = UBound(vData, 1)
nPath = WorksheetFunction.CountIf(rngHeaders, "Path:")
ReDim pathPermissions(1 To nPath)
iRow = 1
'Look for first "Path:" header.
Do Until InStr(vHeaders(iRow, 1), "Path") <> 0
iRow = iRow + 1
Loop
'Found "Path:" header.
For iPath = 1 To nPath
With pathPermissions(iPath)
'Now look for "Owner:" header, adding to the path until it is found.
Do Until InStr(vHeaders(iRow, 1), "Owner") <> 0
.pth = .pth & vData(iRow, 1)
iRow = iRow + 1
Loop
'Found "Owner:" header.
.owner = vData(iRow, 1)
'"User:" header is on next row:
iRow = iRow + 1
'Now add users to list of users:
Set .users = New Dictionary
Do Until InStr(vHeaders(iRow, 1), "Path") <> 0
.users.Add vData(iRow, 1), vData(iRow, 1)
iRow = iRow + 1
If iRow > nRow Then Exit Do ' End of data.
Loop
End With
Next iPath
LoadPathPermissions = pathPermissions
End Function
Example usage:
Dim pathPermissions() As PathPermissionsType
pathPermissions = LoadPathPermissions()
Then to get an array containing the paths for a given user:
Function GetPathsForUser(ByVal user As String, pathPermissions() As PathPermissionsType) As String()
Dim iPath As Long
Dim iPathsWithPermission As Long
Dim nPathsWithPermission As Long
Dim pathsWithPermission() As String
For iPath = LBound(pathPermissions) To UBound(pathPermissions)
If pathPermissions(iPath).users.Exists(user) Then nPathsWithPermission = nPathsWithPermission + 1
Next iPath
ReDim pathsWithPermission(1 To nPathsWithPermission)
iPathsWithPermission = 0
For iPath = LBound(pathPermissions) To UBound(pathPermissions)
If pathPermissions(iPath).users.Exists(user) Then
iPathsWithPermission = iPathsWithPermission + 1
pathsWithPermission(iPathsWithPermission) = pathPermissions(iPath).pth
End If
Next iPath
GetPathsForUser = pathsWithPermission
End Function
Example usage:
Dim pathPermissions() As PathPermissionsType
Dim pathsWithPermission() As String
pathPermissions = LoadPathPermissions()
pathsWithPermission = GetPathsForUser("Kevin", pathPermissions)
Now pathsWithPermission is an array containing the paths for which Kevin is listed as user. Note that I haven't dealt with edge cases, like if Kevin is a not a user for any paths, etc. Up to you to do that.
Finally you can write the contents of that array to your sheet.
In VBA, why does the following fail?
Dim rng as Range
rng = Range("Sheet1:Sheet3!A1")
It throws an HRESULT exception. Is there another way to construct this range in VBA? Note that you can enter a worksheet function like =SUM(Sheet1:Sheet3!A1) and it works fine.
A Range object is limited to only one worksheet. After all, it can have only a single parent.
The =SUM() function can operate on a group of ranges. (this is true for many worksheet functions)
EDIT#1
I have been searching for a solution since Janauary:
UDF Syntax
.
I have been using an array of ranges. Not a very good solution.
Just developing Gary's answer (if you're going to accept an answer, accept his :):
Using Range variable:
Sub SumTest1()
Dim rSheet1 As Range
Dim rSheet2 As Range
Dim rSheet3 As Range
Dim dSum As Double
With ThisWorkbook
Set rSheet1 = .Sheets("Sheet1").Range("A1")
Set rSheet2 = .Sheets("Sheet2").Range("A1")
Set rSheet3 = .Sheets("Sheet3").Range("A1")
End With
dSum = WorksheetFunction.Sum(rSheet1, rSheet2, rSheet3)
Debug.Print CStr(dSum)
End Sub
Using Variant variable:
Sub SumTest2()
Dim vArray As Variant
Dim dSum As Double
With ThisWorkbook
vArray = Array(.Sheets("Sheet1").Range("A1"), .Sheets("Sheet2").Range("A1"), .Sheets("Sheet3").Range("A1"))
End With
dSum = WorksheetFunction.Sum(vArray)
Debug.Print CStr(dSum)
End Sub
Using no variable:
Sub SumTest3()
Dim dSum As Double
With ThisWorkbook
dSum = WorksheetFunction.Sum(Array(.Sheets("Sheet1").Range("A1"), .Sheets("Sheet2").Range("A1"), .Sheets("Sheet3").Range("A1")))
End With
Debug.Print CStr(dSum)
End Sub
Here's a set of UDF functions that accomplish essentially the same thing. The only caveat is that the reference to the 3D range is a string i.e. "Jan:Dec!A1" as opposed to straight up Jan:Dec!A1
'Adapted from https://web-beta.archive.org/web/20060313132405/http://www.j-walk.com/ss/excel/eee/eee003.txt by Andre Terra
Function CountIf3D(Range3D As String, Criteria As String, _
Optional Count_Range As Variant) As Variant
Dim sTestRange As String
Dim sCountRange As String
Dim Sheet1 As Integer
Dim Sheet2 As Integer
Dim n As Integer
Dim Count As Double
Application.Volatile
If Parse3DRange(Application.Caller.Parent.Parent.Name, _
Range3D, Sheet1, Sheet2, sTestRange) = False Then
CountIf3D = CVErr(xlErrRef)
End If
If IsMissing(Count_Range) Then
sCountRange = sTestRange
Else
sCountRange = Count_Range.Address
End If
Count = 0
For n = Sheet1 To Sheet2
With Worksheets(n)
Count = Count + Application.WorksheetFunction.CountIf(.Range _
(sTestRange), Criteria)
End With
Next n
CountIf3D = Count
End Function 'CountIf3D
Function SumIf3D(Range3D As String, Criteria As String, _
Optional Sum_Range As Variant) As Variant
Dim sTestRange As String
Dim sSumRange As String
Dim Sheet1 As Integer
Dim Sheet2 As Integer
Dim n As Integer
Dim Sum As Double
Application.Volatile
If Parse3DRange(Application.Caller.Parent.Parent.Name, _
Range3D, Sheet1, Sheet2, sTestRange) = False Then
SumIf3D = CVErr(xlErrRef)
End If
If IsMissing(Sum_Range) Then
sSumRange = sTestRange
Else
sSumRange = Sum_Range.Address
End If
Sum = 0
For n = Sheet1 To Sheet2
With Worksheets(n)
Sum = Sum + Application.WorksheetFunction.SumIf(.Range _
(sTestRange), Criteria, .Range(sSumRange))
End With
Next n
SumIf3D = Sum
End Function 'SumIf3D
Function AverageIf3D(Range3D As String, Criteria As String, _
Optional Average_Range As Variant) As Variant
Dim sTestRange As String
Dim sSumRange As String
Dim Sheet1 As Integer
Dim Sheet2 As Integer
Dim n As Integer
Dim Sum As Double
Dim Count As Double
Application.Volatile
If Parse3DRange(Application.Caller.Parent.Parent.Name, _
Range3D, Sheet1, Sheet2, sTestRange) = False Then
AverageIf3D = CVErr(xlErrRef)
End If
If IsMissing(Average_Range) Then
sSumRange = sTestRange
Else
sSumRange = Average_Range.Address
End If
Sum = 0
Count = 0
For n = Sheet1 To Sheet2
With Worksheets(n)
Sum = Sum + Application.WorksheetFunction.SumIf(.Range(sTestRange), Criteria, .Range(sSumRange))
Count = Count + Application.WorksheetFunction.CountIf(.Range(sTestRange), Criteria)
End With
Next n
AverageIf3D = Sum / Count
End Function 'SumIf3D
Function Parse3DRange(sBook As String, SheetsAndRange _
As String, FirstSheet As Integer, LastSheet As Integer, _
sRange As String) As Boolean
Dim sTemp As String
Dim i As Integer
Dim Sheet1 As String
Dim Sheet2 As String
Parse3DRange = False
On Error GoTo Parse3DRangeError
sTemp = SheetsAndRange
i = InStr(sTemp, "!")
If i = 0 Then Exit Function
'next line will generate an error if range is invalid
'if it's OK, it will be converted to absolute form
sRange = Range(Mid$(sTemp, i + 1)).Address
sTemp = Left$(sTemp, i - 1)
i = InStr(sTemp, ":")
Sheet2 = Trim(Mid$(sTemp, i + 1))
If i > 0 Then
Sheet1 = Trim(Left$(sTemp, i - 1))
Else
Sheet1 = Sheet2
End If
'next lines will generate errors if sheet names are invalid
With Workbooks(sBook)
FirstSheet = .Worksheets(Sheet1).Index
LastSheet = .Worksheets(Sheet2).Index
'swap if out of order
If FirstSheet > LastSheet Then
i = FirstSheet
FirstSheet = LastSheet
LastSheet = i
End If
i = .Worksheets.Count
If FirstSheet >= 1 And LastSheet <= i Then
Parse3DRange = True
End If
End With
Parse3DRangeError:
On Error GoTo 0
Exit Function
End Function 'Parse3DRange
Untested, but try this
Dim rng as string
rng = "Sheet1:Sheet3!A1"
worksheet("Sheet1").range("B1").formula = "=SUM(" & rng & ")"
I have a simple piece of code written which basically scans through column A, detects for a condition and once the condition is met in a row, it copies the cell in column B of the same row into an array. I was hoping someone could help me make a nested array which would not only store the value in column B but also its rowcount. here is what i have so far, any help is appreciated.
Dim col2 As Range
Dim cell2 As Excel.Range
Dim rowcount2 As Integer
Dim ii As Integer
ii = 0
rowcount2 = DataSheet.UsedRange.Rows.Count
Set col2 = DataSheet.Range("A1:A" & rowcount2)
Dim parsedcell() As String
Dim oldarray() As String
For Each cell2 In col2
If cell2.Value <> Empty Then
parsedcell = Split(cell2.Value, "$")
sheetName = parsedcell(0)
If sheetName = DHRSheet.Name Then
Dim oldvalue As Range
ReDim Preserve oldarray(ii)
Set oldvalue = DataSheet.Cells(cell2.Row, 2)
oldarray(ii) = oldvalue.Value
ii = ii + 1
End If
End If
Next
You need a two dimensional array. Use one dimension for the value and the other for the row. Here's an example
Sub GetArray()
Dim vaInput As Variant
Dim rRng As Range
Dim aOutput() As Variant
Dim i As Long
Dim lCnt As Long
'Define the range to test
Set rRng = DataSheet.Range("A1", DataSheet.Cells(DataSheet.Rows.Count, 1).End(xlUp)).Resize(, 2)
'Put the values in that range into an array
vaInput = rRng.Value
'Lopo through the array
For i = LBound(vaInput, 1) To UBound(vaInput, 1)
'Skip blank cells
If Len(vaInput(i, 1)) > 0 Then
'Test for the sheet's name in the value
If Split(vaInput(i, 1), "$")(0) = DHRSheet.Name Then
'Write the value and row to the output array
lCnt = lCnt + 1
'You can only adjust the second dimension with a redim preserve
ReDim Preserve aOutput(1 To 2, 1 To lCnt)
aOutput(1, lCnt) = vaInput(i, 2) 'write the value
aOutput(2, lCnt) = i 'write the row count
End If
End If
Next i
'Output to see if you got it right
For i = LBound(aOutput, 2) To UBound(aOutput, 2)
Debug.Print aOutput(1, i), aOutput(2, i)
Next i
End Sub
Dim col2 As Range
Dim cell2 As Excel.Range
Dim rowcount2 As Integer
Dim arr() As Variant
Dim p As Integer
p = 0
rowcount2 = DataSheet.UsedRange.Rows.Count
Set col2 = DataSheet.Range("A1:A" & rowcount2)
Dim parsedcell() As String
For Each cell2 In col2
If cell2.Value <> Empty Then
parsedcell = Split(cell2.Value, "$")
sheetName = parsedcell(0)
If sheetName = DHRSheet.Name Then
Dim subarr(1) As Variant
Dim oldvalue As Range
ReDim Preserve arr(p)
Set oldvalue = DataSheet.Cells(cell2.Row, 2)
subarr(0) = oldvalue.Value
subarr(1) = cell2.Row
arr(p) = subarr
p = p + 1
'MsgBox (oldvalue)
End If
End If
Next