I have been working on getting a timesheet macro that will take a data dumps and make do a few things.
Ultimately I am not familiar with the syntax of VBA and have got close however am needing help with getting this finished.
Below will be my code and comments where I am working on code as well as a screenshot for reference of the spreadsheet.
My question is how do I properly write the syntax using vars?
For instance in this line of code: If IsNumeric(Cells("Fr").Value) Then
I am geting errors and am unsure how I would enter the r value from the loop.
This applies to a few of the other lines I was getting errors for but didn't know
how to use r to identify a row.
Sub sum()
Dim r As Integer, c As Integer, s As Double, t As Integer, g As Integer
r = 2 'looping var
c = 3 'looping var
s = 0 'var for sum
g = 0
t = ActiveSheet.UsedRange.Rows.Count 'var for total rows
Do Until r = t
If Not IsEmpty(Range("Ar").Value) = True Then 'check if user name is present then
'Detect the next cell that contains data in the user name column
'Use that number between the two as a var (g) that will be used to run the embedded looping
'essentially redefining the other loop each time to account for the different number of clock ins per user
Do Until c = g 'Loop for until the next name was detected via var (g)
If IsNumeric(Cells("Fr").Value) Then 'check if Billable has a number then
s = s + Range("r, F").Value 'adds cell value (numbers only) to sum
c = c + 1 'add 1 to the value of c
Loop 'closes embedded loop once values have been added up
Range("Fr") = s 'Replace Cell (Fr) with the sum value
s = 0 'reset the value of the sum
r = r + 1
Loop
End Sub
Related
I have the need to automatic create report that is based on the dates and portfolios.
For example if I put 2 dates and 2 portfolios like this
The report should look like this:
So if we enter 3 dates and 4 portfolios the report should have 3 tables and each one has 4 portfolios...
I'm ok to do it manual but it is ideally to be automatic,(I think it can be done through VBA, but not quite sure about it) can you guys help? Thank you.
You have to to move your data from where is stored to the Project sheet.
I guess that the date doesn't make any different on the portfolio, isn't it?
If so, it's quite easy. I don't know how your data is stored, but let's guess it's equal as shown it your screenshot.
Option Base 1 'array will start at 1 instead of 0
Public Setting As Worksheet, ListPortfolios As Worksheet, Project As Worksheet
Public RangeSelectDates As Range, RangeSelectPortfolios As Range, RowOfCodePortfolios As Range
Public ArraySelectDates(), ArraySelectPortfolios(), ArrayOfCodePortfolios(), ArrayPortfolio(), ArrayProject()
Public PortfolioCode$
Dim i%, j%, k%, r%, c%
Sub Automate()
Set Setting = Worksheets("Setting")
Set ListPortfolios = Worksheets("ListPortfolios")
Set Project = Worksheets("Project")
'First, read the portfolio code and dates to import and store in array
With Setting
Set RangeSelectDates = .Cells(4, 5).CurrentRegion
Set RangeSelectPortfolios = .Cells(4, 8).CurrentRegion
End With
ArraySelectDates = RangeSelectDates
ArraySelectPortfolios = RangeSelectPortfolios 'store the range in a Array
ReDim ArrayProject(1 To 24, 1 To 1)
'Now, create an array with the names of the portfolios where you have stored them. I don't know how your data is stored.
'I assume you've got it as the Project sheet result it's shown and also at "ListPortfolios" sheet
With ListPortfolios
Set RowOfCodePortfolios = .Rows(5)
End With
ArrayOfCodePortfolios = RowOfCodePortfolios 'store the row in a Array
k = 0 'means no value is found
For i = LBound(ArraySelectPortfolios) To UBound(ArraySelectPortfolios) 'Navigate to all the Portfolios Selected
'the portfolio codes are stored in the "second column" of the array, say PortfolioCode is the name of the portfolio
PortfolioCode = ArraySelectPortfolios(i, 2)
For j = LBound(Application.Transpose(ArrayOfCodePortfolios)) To UBound(Application.Transpose(ArrayOfCodePortfolios)) 'now navigate to where your portfolios are stored
If ArrayOfCodePortfolios(1, j) = PortfolioCode Then 'if match, create a new array with the whole portfolio
With ListPortfolios
ArrayPortfolio = .Range(.Cells(1, j), .Cells(24, j + 2)) 'I don't know the size of your data. I assume that the first column is the same of where the portfoliocode is stored and its size is 24 rows x 3 columns
End With
'now, copy it to the Project Portfolio
ReDim Preserve ArrayProject(1 To 24, 1 To 3 + k * 3)
For r = 1 To 24 'from the r (row) one to 24th. I don't know how your data is stored
For c = 1 To 3 'from the column 1 to the 3rd of each portfolio
ArrayProject(r, c + k * 3) = ArrayPortfolio(r, c) 'built the result for each portfolio found
Next c
Next r
k = k + 1 'one value is found, let's go for the next one if so
End If
Next j
Next i
If k <> 0 Then 'if any value is found then
For i = 1 To UBound(ArraySelectDates) 'let's place the date and print to the excel
ArrayProject(2, 1) = ArraySelectDates(i, 2) 'paste the date into the array
With Project
.Range(.Cells(1, 4 + 1 + (i - 1) * k), .Cells(24, UBound(Application.Transpose(ArrayProject)) + 3 + (i - 1) * k)) = ArrayProject 'print the array
'1+(i-1)*k is the first column + which date are we copying times portfolio codes found
End With
Next i
End If
End Sub
There's no error handling, either if there aren't input values may crash. But first, make it work
I'm trying to solve a problem in VBA and after a long time of browsing the web for solutions, I really hope someone is able to help me.
It's actually not a very hard task, but with very little programming and VBA knowledge as a new learner, I hope I can find a useful tip or solution with the help of the community.
So my problem is as follows:
I have a table with 3 columns, the first is filled with a number to use as an ID. Column 2 and 3 have different values that needs to be compared:
What I'd like to do is select the range of column rows of column 2 and 3 based on the same ID. Once I have selected the relevant ranges of the columns, I want to compare if one name of column 2 matches one name of column 3.
So there is no need to have all names of the desired column ranges to match. One name match is enough. If a name matches, it should automatically fill in a new column "result" with 1 for match (0 for no match).
Do you have an idea, how I can select specific cells of a column based on an identifier?
Dim ID_counter As Long
ID_counter = 1
If Cell.Value = ID_counter IN Range("Column1")
Then Range("Column2").Select
AND Range("Column3").Select
WHERE ID_counter is the same
In Column4 (If one Cell.Value IN Range("Column2-X:Column2-Y")
IS IDENTICAL TO Range("Column3-X:Column3-Y"), return 1, else return 0
End Sub
Many thanks in advance for your help!
This works for your example so perhaps you can generalise it. The formula in D2 is
=IF(A2=A1,"",MAX(IF($A$2:$A$10=A2,COUNTIF($B$2:$B$10,$C$2:$C$10))))
and is an array formula so must be confirmed with CTRL, SHIFT and ENTER.
Array alternative via Match() function
This approach compares the string items of columns B and C by passing two arrays (named b,c) as arguments (c.f. section [1]):
chk = Application.Match(b, c, 0)
The resulting chk array reflects all findings of the first array's items via (1-based) position indices of corresponding items in the second array.
Non-findings return an Error 2042 value (c.f. section [2]b)); assumption is made that data are grouped by id.
Sub OneFindingPerId()
'[0]get data
Dim data: data = Sheet1.Range("A1:D10") ' << project's sheet Code(Name)
Dim b: b = Application.Index(data, 0, 2) ' 2nd column (B)
Dim c: c = Application.Index(data, 0, 3) ' 3rd column (C)
'[1]get position indices of identic strings via Match() function
Dim chk: chk = Application.Match(b, c, 0) ' found row nums of a items in b
'[2]loop found position indices (i.e. no error 2042)
Dim i As Long
For i = 2 To UBound(chk) ' omit header row
'a) define start index of new id and initialize result with 0
If data(i, 1) <> data(i - 1, 1) Then
Dim newId As Long: newId = i
data(newId, 4) = 0
End If
'b) check if found row index corresponds to same id
If Not IsError(chk(i, 1)) Then ' omit error 2042 values
If data(chk(i, 1), 1) = data(i, 1) Then ' same ids?
If data(newId, 4) = 0 Then data(newId, 4) = 1 ' ~> result One if first occurrence
End If
End If
Next i
'[3]write results
Sheet1.Range("A1").Resize(UBound(data), UBound(data, 2)) = data
End Sub
First enter this user defined function in a standard module:
Public Function zool(r1, r2, r3) As Integer
Dim i As Long, v1 As Long, v2 As String
Dim top As Long, bottom As Long
zool = 0
v1 = r1.Value
top = r1.Row
' determine limits to check
For i = top To 9999
If v1 <> r1.Offset(i - top, 0).Value Then
Exit For
End If
Next i
bottom = i - 1
For i = top To bottom
v2 = Cells(i, "B").Value
If v2 <> "" Then
For j = top To bottom
If v2 = Cells(j, "C").Value Then zool = 1
Next j
End If
Next i
End Function
Then in D2 enter:
=IF(OR(A2="",A2=A1),"",zool(A2,B2,C2))
and copy downwards:
(this assumes that the data has been sorted or organized by ID first)
I seem to be having issues finding a solution,
I want to count duplications in a row, the row has 100 columns. I Just want to count many how duplications across the row.
For example,
1,2,3,1,4,9,2,9,1,4
I just want to see how many times the same set of numbers show up.
1 = 3
2 = 2
3 = 0
4 = 2
9 = 2
For example, 3 + 2 + 0 + 2 + 2 = 9
This row has 9 duplications. ie the same value is being displayed more than once. However the value is dynamic.
The VBA function below is a UDF, meaning it's like a normal Excel worksheet function but doing designed to do precisely what you want. Install it in a standard code module.
Function CountDuplicates(Rng As Range) As Integer
' set a Reference to "Microsoft Scripting Runtime"
Dim Fun As Integer ' function return value
Dim Uniques As Scripting.Dictionary ' list of occurrences
Dim Arr As Variant ' array of all values
Dim C As Long
Set Uniques = CreateObject("Scripting.Dictionary")
Arr = Rng.Value
With Uniques
For C = 1 To UBound(Arr, 2)
If Not IsEmpty(Arr(1, C)) Then
If .Exists(Arr(1, C)) Then
.Item(Arr(1, C)) = .Item(Arr(1, C)) + 1
Else
.Add Arr(1, C), 0
End If
End If
Next C
For C = 0 To .Count - 1
Fun = Fun + .Items(C)
Next C
End With
CountDuplicates = Fun
End Function
A standard code module is one that you must add to your project. Its default name will be like Module1 but you can change it to anything you like (wrong syntax names will be rejected). Call the function from the worksheet by entering its call in any cell, for example.
= CountDuplicates(A2:DD2)
This function will return the number of all duplicates counted in the defined range, excluding unique values. Look at the code. When an item is found for the first time a value of 0 is recorded against it. Thereafter, each time it is found again 1 is added to the number of recurrences already found. In the end all values will be added up to return the total count. This method ensures that all first occurrences will be counted as 0 (meaning not counted). Only repeats are included in the returned total.
As with other Excel functions, the result will appear in the cell containing the formula. You can copy that formula down as you do with any other, meaning the original above must be in row 2. If you paste it elsewhere consider the use of absolute addressing to define the action range.
If you have O365 with the UNIQUE function, you can use:
=COUNT(A1:J1)-COUNT(UNIQUE(A1:J1,TRUE,TRUE))
Another way
=COUNT(A1:J1)-SUMPRODUCT(--(FREQUENCY(A1:J1,A1:J1)=1))
or
=SUMPRODUCT(--(COUNTIF(A1:J1,A1:J1)>1))
I am currently trying to check cells from 2 columns (one for loop for each) and see whether they have the string true. If yes I would like to copy some cells corresponding, to another sheet(log).
I know that I have some cells, which contain the word true but when I run the program there is nothing that is copied in my other sheet.
I do not get any compiling errors and would like to know where I am wrong in this code.
Sub isLimit()
Dim a As Long, b As Long, Lr As Long
x = 2
y = 2
Lr = Worksheets("Targets").Cells(Rows.Count, "A").End(xlUp).Row
For i = 8 To Lr
If (StrComp(Cells(i, 15).Text, "TRUE")) = 0 Then
Worksheets("Log").Range("B" & x) = "no"
x = x + 1
End If
Next i
For j = 8 To Lr
If (StrComp(Cells(j, 16).Text, "TRUE")) = 0 Then
Worksheets("Log").Range("B2") = Worksheets("Targets").Range("B1").Value
Worksheets("Log").Range("C" & y) = "yes"
y = y + 1
End If
Next j
End Sub
So far, I can see two problems that might causing you the trouble.
1.Since you are not setting which sheets to be checked from line below,
It will check for the activesheet cells i,15 then return -1 or 0 (true or false).
Which will only work when your screen displays sheet where data is stored.
If (StrComp(Cells(i, 15).Text, "TRUE")) = 0 Then
2.If your DATA contains something else then TRUE (for example space before or after the value).
It might see it as something other than "TRUE"
That's all I can tell without looking at your actual data.
I have the following table, Column(Dates), Rows(Id and Names). I am trying to add the values in each row only if there are seven consecutive values in them otherwise not. Never done any coding in vba so I am having hard time. Tried to write the formula and vba code but not knowing the syntax it's been very difficult.
Scan from C2 to AG2
if C2 is > 0 and C2=D2=E2=F2=G2=H2=I2 then
add C2+D2+E2+F2+H2+I2 store this value in AL2
Repeat the process until last filled row
Any insight into this would be greatly appreciated. I tried extensive search on this site and on google but couldn't find anything that is close to what I am doing, I was able to learn how to get the last filled column (in my case it only goes up to AH), last filled row (in my case it only goes up to 55), for loop. but not able to put this together.
Thx,
Archer
A VBA user-defined-function
EDIT: updated to ignore blanks
Function GetRun(rng, num)
Dim d, i As Long, c As Long, v, rv, tmp
d = rng.Value
v = Chr(0)
rv = ""
For c = 1 To UBound(d, 2) - 1
tmp = d(1, c)
'EDIT: skip blanks
If tmp <> v Or Len(tmp) = 0 Then
v = tmp
i = 1
Else
i = i + 1
If i = num Then
rv = v
Exit For
End If
End If
Next c
GetRun = rv
End Function
Use:
=GetRun(C2:AG2, 7)