I have a workbook and macro to calculate sum from multiple worksheets and put it to the master sheet. Below is my current macro which works fine. But I need to add one more additional condition to SUM. I think this can be done by using sumif. I have attached my workbook below explaining about my current outcome and expected outcome.
Sub GetSums()
Dim lngCol As Long, wsName As Range
With Sheets("Master")
If .[C3] <> "" Then .Range("C3", .[B3].End(2)) = ""
For Each wsName In .Range("C2", .[B2].End(2))
lngCol = Sheets(wsName.Value).Rows(1).Find("My Text").Column
wsName.Offset(1).Value = _
Evaluate("Sum('" & wsName.Value & "'!" & Cells(3, lngCol + 1).Address & ":" & _
Sheets(wsName.Value).Cells(Rows.Count, lngCol + 1).End(3).Address & ")")
Next wsName
End With
End Sub
Master Sheet
Sheet1
Sheet2
This is how it would look using Sumifs:
Sub GetSums()
Dim lngCol As Long, wsName As Range
With Sheets("Master")
If .[C3] <> "" Then .Range("C3", .[B3].End(2)) = ""
For Each wsName In .Range("C2", .[B2].End(2))
lngCol = Sheets(wsName.Value).Rows(1).Find("My Text").Column
wsName.Offset(1).Value = _
Evaluate("Sumifs('" & wsName.Value & "'!" & Cells(3, lngCol + 1).Address & ":" & _
Sheets(wsName.Value).Cells(Rows.Count, lngCol + 1).End(3).Address & ",'" & _
wsName.Value & "'!" & Cells(3, 2).Address & ":" & _
Sheets(wsName.Value).Cells(Rows.Count, 2).End(3).Address & "," & _
"""ABC"")")
Next wsName
End With
End Sub
BTW I would normally use End(xlToRight) and End(xlUp) rather than End(2) and End(3) ...
Related
I'm setting up a new macro to assign comments on a range of Cells with information from another range of cells. I Keep getting an
"Object Required" error.
I ran the code on a more simple workbook and it worked great. When I adapted for new column, sheet, row names and different ranges I ran into the error.
Dim rngCell As Range
Dim strComment As String, strConsolidated As String, strPERSON As String, strConcat As String
Dim arrConcat() As String
Dim lngPos As Long
Dim WIPDATA As Worksheet
Dim Display As Worksheet
Set WIPDATA = Worksheets("WIPDATA")
Set Display = Worksheets("Display")
For Each rngCell In WIPDATA.Range("I2:I278")
strConcat = strConcat & rngCell & rngCell.Offset(0, -7) & "||"
Next rngCell
arrConcat = Split(strConcat, "||")
For Each rngCell In Display.Range("D3:F23")
If rngCell.Value >= 0 Then
strConsolidated = Right(Display.Cells(rngCell.Row, 1).Value, 1)
strPERSON = Display.Cells(1, rngCell.Column).Value
For lngPos = 0 To UBound(arrConcat)
If LCase$(strConsolidated & strPERSON) = LCase$(arrConcat(lngPos)) Then
With WIPDATA
strComment = strComment & Chr(10) _
& "W/O " & .Range("B" & lngPos + 2).Value & Chr(10) _
& "OP# " & .Range("F" & lngPos + 2).Value & Chr(10) _
& "Qty " & .Range("I" & lngPos + 2).Value
End With
End If
Next lngPos
rngCell.ClearComments
If Len(strComment) > 0 Then
rngCell.AddComment (Right(strComment, Len(strComment) - 1))
rngCell.Comment.Shape.TextFrame.AutoSize = True
End If
strComment = vbNullString
End If
Next rngCell
End Sub
If it goes right, Notes are added to each cell in the range with corresponding data from the following sheet.
This is solved: Get a
Run-time error '424' Object Required
And it takes me to line 5. For Each rngCell In WIPDATA.Range("I2:I278")
Now I get notes applied to "E" and "F" But they aren't grabbing any values from the second sheet. Pictures updated to show latest.
Please Keep in mind that I'm mainly adapting already written code. Still very much learning and teaching myself at that.
Hopefully I was able to recreate your dataset properly. Assuming that you want to match Display sheet, Person (row 2) & Consolidated number (column C), with WIPDATA, Person (column A) & Consolidated number (column P), then you would need to use the following code:
Sub foo()
Dim rngCell As Range
Dim strComment As String, strConsolidated As String, strPERSON As String, strConcat As String
Dim arrConcat() As String
Dim lngPos As Long
Dim WIPDATA As Worksheet
Dim Display As Worksheet
Set WIPDATA = Worksheets("WIPDATA")
Set Display = Worksheets("Display")
For Each rngCell In WIPDATA.Range("A2:A278")
strConcat = strConcat & rngCell.Offset(0, 15) & rngCell & "||"
Next rngCell
arrConcat = Split(strConcat, "||")
For Each rngCell In Display.Range("D3:F23")
If rngCell.Value >= 0 Then
strConsolidated = Display.Cells(rngCell.Row, 3).Value
strPERSON = Display.Cells(2, rngCell.Column).Value
For lngPos = 0 To UBound(arrConcat)
If LCase$(strConsolidated & strPERSON) = LCase$(arrConcat(lngPos)) Then
With WIPDATA
strComment = strComment & Chr(10) _
& "W/O " & .Range("B" & lngPos + 2).Value & Chr(10) _
& "OP# " & .Range("F" & lngPos + 2).Value & Chr(10) _
& "Qty " & .Range("I" & lngPos + 2).Value
End With
End If
Next lngPos
rngCell.ClearComments
If Len(strComment) Then
rngCell.AddComment (Right(strComment, Len(strComment) - 1))
rngCell.Comment.Shape.TextFrame.AutoSize = True
End If
strComment = vbNullString
End If
Next rngCell
End Sub
Display sheet on my side displays two comments (yellow & orange colours):
WIPDATA setup (sorry, I was being lazy and I only copied part of your table!):
I created only 3 scenarios where Person & Consolidated match between both sheets, but hopefully you will be able to see that yellow & orange coloured rows are properly being copied into Display sheet comments.
Give it a try and let me know if you need any further help.
I'm currently trying to create a total, min, max, and average table at the bottom of the sheet. I would also like the "table" to start two cells below the last populated cell.
I am pulling in varying amounts of data which could be a single day, or as many as 100.
Sub max()
Dim N As Long
N = Cells(Rows.COUNT, "B").End(xlUp).Row
'Cells(N + 1, "B").Formula = "=MAX(B$13:B$44" & N & ")" <-COMMENTED OUT / THIS WORKS
Cells(N + 1, "B").Formula = "=IF(COUNT(B$13:B$44)=0,"",MAX(B$13:B$44))" & N & ")"
End Sub
This is what I have so far. I'm getting a 1004 error, and realize I am not calling the variable correctly. I will also need to do this across about 200 columns. Where am I going wrong?
EDIT: Update for non-contiguous tables.
This assumes you don't have anything below or to the right of the table on the worksheet and that your table starts at B13 (headers would be row 12):
Option Explicit
Public Sub BuildStatsTable()
Dim lngMaxRow As Long
Dim lngMaxCol As Long
Dim lngCol As Long
Dim strRng As String
Dim rngLastUsed As Range
Set rngLastUsed = GetLastRange(Cells(13, 2))
lngMaxCol = rngLastUsed.Column
lngMaxRow = rngLastUsed.Row
For lngCol = 2 To lngMaxCol
strRng = "R13C" & lngCol & ":R" & lngMaxRow & "C" & lngCol
Cells(lngMaxRow + 2, lngCol).FormulaR1C1 = "=IF(COUNT(" & strRng & ")=0,"""",SUM(" & strRng & "))"
Cells(lngMaxRow + 3, lngCol).FormulaR1C1 = "=IF(COUNT(" & strRng & ")=0,"""",MIN(" & strRng & "))"
Cells(lngMaxRow + 4, lngCol).FormulaR1C1 = "=IF(COUNT(" & strRng & ")=0,"""",MAX(" & strRng & "))"
Cells(lngMaxRow + 5, lngCol).FormulaR1C1 = "=IF(COUNT(" & strRng & ")=0,"""",AVERAGE(" & strRng & "))"
Next lngCol
End Sub
Private Function GetLastRange(rngTopLeft As Range) As Range
Dim rngUsed As Range
Dim lngMaxRow As Long
Dim lngMaxCol As Long
Set rngUsed = Range(rngTopLeft, rngTopLeft.SpecialCells(xlCellTypeLastCell))
lngMaxRow = rngUsed.Find(What:="*", _
After:=rngUsed.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
lngMaxCol = rngUsed.Find(What:="*", _
After:=rngUsed.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
Set GetLastRange = Cells(lngMaxRow, lngMaxCol)
End Function
When trying to use VBA to create a formula, and in that formula you want to use quotes, you have to "double up":
Cells(N + 1, "B").Formula = "=IF(COUNT(B$13:B$44)=0,"""",MAX(B$13:B$44))" & N & ")"
You can use Chr(34) to append it to the formula.
Cells(N + 1, "B").Formula = "=IF(COUNT(B$13:B$44)=0,"& Chr(34) & Chr(34) &",MAX(B$13:B$44))" & N & ")"
I am trying to make it easier for users to work with an excel sheet instead of having to modify an arduous expression anytime a change is needed. I am dynamically placing the function's result into a cell. I got everything functioning how it should except:
If I go to another sheet and use the formula, it will return the proper results; however, when returning to another sheet that was already using using it, that sheet will display the most resent results and no longer its own instance of passed variables. These sheets also tie into a dashboard sheet so I need to make sure that if I calculate one sheet, it doesn't tamper with the others. I wasn't sure how to word this issue, so if there is nomenclature in place that I am not using or if this has been answered in the past, let me know and I will close this out.
'-------------------
'getScore
' This function is called from a cell and is passed an intager.
' The integer represents the section that it is being called from.
' There is also the sheet title that is passed thrugh to the range.
'-------------------
Function getScore(section As Integer, sheetTitle As String)
Application.Volatile
Dim rngSt As Integer
Dim rngEnd As Integer
rngSt = getRange(section, sheetTitle, 1) 'Gets start range for formula
rngEnd = getRange(section, sheetTitle, 2) 'Gets end range for formula
Dim Formula As String 'Broken into seperate concatinated lines for readablility
'-(COUNTBLANK(H" & rngSt & ":H" & rngEnd & ")),"
' This section uses nested if statements to acrue the score through each level.
Formula = "=IF(SUM(D" & rngSt & ":D" & rngEnd & ")= nonBlank(D" & rngSt & ":D" & rngEnd & "),"
Formula = Formula & "IF(SUM(F" & rngSt & ":F" & rngEnd & ")= nonBlank(F" & rngSt & ":F" & rngEnd & "),"
Formula = Formula & "IF(SUM(H" & rngSt & ":H" & rngEnd & ")= nonBlank(H" & rngSt & ":H" & rngEnd & "),"
Formula = Formula & "IF(SUM(J" & rngSt & ":J" & rngEnd & ")= nonBlank(J" & rngSt & ":J" & rngEnd & "),"
Formula = Formula & "IF(SUM(L" & rngSt & ":L" & rngEnd & ")= nonBlank(L" & rngSt & ":L" & rngEnd & "),5,4),3),2),1), 0)"
getScore = Eval(Formula) 'Evaluates formula and returns a score of 0-5.
End Function
Here is the getRange fucntion
Function getRange(section As Integer, sheetName As String, rangePoint As Integer)
Application.Volatile
Dim FindRow As Range
Dim ws As Worksheet
Dim wb As Workbook
Set wb = ActiveWorkbook
If section = 1 Then
If rangePoint = 1 Then
With wb.Sheets(sheetName)
Set FindRow = .Range("C9:C9")
End With
getRange = FindRow.Row
End If
If rangePoint = 2 Then
With wb.Sheets(sheetName)
Set FindRow = .Range("C:C").Find(What:="rngEnd", LookIn:=xlValues)
End With
getRange = FindRow.Row - 1
End If
End IF
End Function
Here is my Eval fuction
Function Eval(Ref As String)
Application.Volatile
Eval = Evaluate(Ref)
End Function
nonBlank fucntion
Function nonBlank(r As Range) As Long 'Counts and returns the number of non blank cells found in given range.
Application.Volatile
nonBlank = r.Cells.Count - WorksheetFunction.CountBlank(r)
End Function
In your case, the function is returning exactly what you tell it to. Your UDF has no specification of worksheet anywhere. What you see on the first sheet, after the second sheet calculates, is the returned value of the function, since it calculated on the second sheet. It's a little confusing, so let me try to break it down another way.
You enter a formula with UDF on Sheet1
UDF calculates on Sheet1, with Sheet1 ranges
You navigate to Sheet2 and recalculate UDF entered there
UDF calculates on Sheet2, with Sheet2 ranges
Concurrently on Sheet1 the UDF also calculates, with Sheet2 ranges (this is why you get the same results)
Since calculation doesn't happen when you change sheets, you still see the results calculated correctly.
Bottom line (TL;DR): Your UDF is poorly written.
To help with an answer to your question, please post your getRange function as Scott asked, as well as an example of how you are calling the UDF.
Edit: I see you posted the getRange function, but it's not complete. I think you're missing an End If statement perhaps. Also, your getScore function doesn't compile because you have an extra ">" character in there. Not sure what it's doing in there.
Formula = "=IF(SUM('" & sheetTitle & "'D" & rngSt & ":D" & rngEnd & ")= nonBlank('" & sheetTitle & "'D" & rngSt & ":D" & rngEnd & "),"
Formula = Formula & "IF(SUM('" & sheetTitle & "'F" & rngSt & ":F" & rngEnd & ")= nonBlank('" & sheetTitle & "'F" & rngSt & ":F" & rngEnd & "),"
Formula = Formula & "IF(SUM('" & sheetTitle & "'H" & rngSt & ":H" & rngEnd & ")= nonBlank('" & sheetTitle & "'H" & rngSt & ":H" & rngEnd & "),"
Formula = Formula & "IF(SUM('" & sheetTitle & "'J" & rngSt & ":J" & rngEnd & ")= nonBlank('" & sheetTitle & "'J" & rngSt & ":J" & rngEnd & "),"
Formula = Formula & "IF(SUM('" & sheetTitle & "'L" & rngSt & ":L" & rngEnd & ")= nonBlank('" & sheetTitle & "'L" & rngSt & ":L" & rngEnd & "),5,4),3),2),1), 0)"
Please note this is the quick fix. I wouldn't write a UDF this way. But we would need much more detail if we delve into that.
EDIT: If I understood what you need, this is a much shorter version and should fix the issue you're seeing...
Function Score( _
ByVal Section As Long, _
ByVal Anchor As Range _
) As Long
Dim CheckRange As Range
Application.Volatile True
Set CheckRange = Anchor.Parent.Range("C9", Anchor.Parent.Cells(Anchor.Parent.Rows.Count, "C").End(xlUp))
Score = Abs(CLng(WorksheetFunction.CountA(CheckRange.Offset(0, 1)) = CheckRange.Cells.Count) + _
CLng(WorksheetFunction.CountA(CheckRange.Offset(0, 3)) = CheckRange.Cells.Count) + _
CLng(WorksheetFunction.CountA(CheckRange.Offset(0, 5)) = CheckRange.Cells.Count) + _
CLng(WorksheetFunction.CountA(CheckRange.Offset(0, 7)) = CheckRange.Cells.Count) + _
CLng(WorksheetFunction.CountA(CheckRange.Offset(0, 9)) = CheckRange.Cells.Count))
End Function
You would then call these from any cell like this...
=Score(1,A1)
=Score(1,Sheet2!A1)
=Score(1,'Some other sheet'!A1)
I'm not even sure what the 'Section' variable is for. There isn't much explanation here.
Thanks, Zack Barresse
I wrote some code which works perfectly as it should when I debug it. But when I remove the breakpoint and just run the code, it give a runtime error:
runtime error '1004'
Method Range of object_worksheet failed.
It refers to the next line:
Set copyrange = sh.Range("A" & i & ":E" & i & ",I" & i & ":O" & i & ",Q" & i & ",V" & i) 'name column in sheet = Q
But while debugging it, there isn't a problem. Maybe the cache is full?
Private Sub btnGetDevices_Click()
'open every sheet after summary
'copy columns A,B,C,D,E,I,J,K,L,M,N,O, Q,V to summary
Dim sh As Worksheet
Dim copyrange As Range
Application.ScreenUpdating = False
Sheets("Summary").Rows(4 & ":" & Sheets("Summary").Rows.Count).Delete
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> "Database" And sh.Name <> "Template" And sh.Name <> "Help" And sh.Name <> "OVERVIEW" And sh.Name <> "Develop" And sh.Name <> "Schedule" And sh.Name <> "Information" And sh.Name <> "Announcements" And sh.Name <> "Summary" Then
sh.Select
LastRow = ActiveSheet.Range("L1048555").End(xlUp).Row
For i = 14 To LastRow
If sh.Range("Q" & i).Value <> Empty And sh.Range("N" & i).Value <> "Designer" And sh.Range("O" & i).Value <> "Layouter" Then
Set copyrange = sh.Range("A" & i & ":E" & i & ",I" & i & ":O" & i & ",Q" & i & ",V" & i) 'name column in sheet = Q
NameDevice = sh.Range("Q" & i).Value
adressDevice = sh.Range("Q" & i)
copyrange.Copy
Sheets("Summary").Select
LastRowsummary = ActiveSheet.Range("A1048555").End(xlUp).Row
Range("B" & LastRowsummary + 1).Select
ActiveSheet.Paste
Range("A" & LastRowsummary + 1) = sh.Name
Range("A" & LastRowsummary + 1, "O" & LastRowsummary + 1).Borders.LineStyle = xlContinuous
Sheets("Summary").Hyperlinks.Add anchor:=Sheets("Summary").Range("N" & LastRowsummary + 1), Address:="", SubAddress:="'" & sh.Name & "'!A1", TextToDisplay:=NameDevice
End If
Next
End If
Next
Application.ScreenUpdating = True
Sheets("Summary").Activate
End Sub
*edit: After some testing I noticed that the error is gone when I use a full range of columns instead of only some columns.
with error:
Set copyrange = sh.Range("A" & i & ",V" & i)
w/o error:
Set copyrange = sh.Range("A" & i & ":E" & i)
*second edit:
I'm using the code from 'Tim Williams'. There was the same error. Instead of using:
rw.Range("A1:E1,I1:O1,Q1,V1").Copy rng.Offset(0, 1)
I've found a workaround. I split it up.
rw.Range("I1:O1").Copy rng.Offset(0, 6)
rw.Range("Q1").Copy rng.Offset(0, 13)
rw.Range("V1").Copy rng.Offset(0, 14)
Now this works without error. But if anyone knows what causes the problem, you may always share it. Thanks in advance.
*third edit:
I still don't know why it doesn't work. It has something to do with range from different columns. The funny (and very frustrated part) is that I use range this way in another sheet and there I don't have this problem. It is driving me mad. Does someone have an idea?
Compiled but not tested"
Private Sub btnGetDevices_Click()
'open every sheet after summary
'copy columns A,B,C,D,E,I,J,K,L,M,N,O, Q,V to summary
Dim sh As Worksheet, shtsumm As Worksheet
Dim copyrange As Range, arrExclude, rw As Range
Dim lastRow As Long, i As Long, rng As Range
Dim NameDevice, adressDevice
'sheets to ignore
arrExclude = Array("Database", "Template", "Help", "OVERVIEW", _
"Develop", "Schedule", "Information", "Announcements", _
"Summary")
Set shtsumm = Sheets("Summary")
Application.ScreenUpdating = False
shtsumm.Rows(4 & ":" & shtsumm.Rows.Count).Delete
For Each sh In ActiveWorkbook.Worksheets
If IsError(Application.Match(sh.Name, arrExclude, 0)) Then
lastRow = sh.Cells(sh.Rows.Count, "L").End(xlUp).Row
For i = 14 To lastRow
Set rw = sh.Rows(i)
If rw.Cells(1, "Q").Value <> Empty And _
rw.Cells(1, "N").Value <> "Designer" And _
rw.Cells(1, "O").Value <> "Layouter" Then
NameDevice = rw.Range("Q1").Value
adressDevice = rw.Range("Q1").Value '<<<typo ?
'find destination
Set rng = shtsumm.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
rng.Value = sh.Name
'Here Range is relative to *rw*, not to the whole sheet
rw.Range("A1:E1,I1:O1,Q1,V1").Copy rng.Offset(0, 1)
rng.Resize(1, 15).Borders.LineStyle = xlContinuous
shtsumm.Hyperlinks.Add _
anchor:=rng.EntireRow.Cells(1, "N"), _
Address:="", SubAddress:="'" & sh.Name & "'!A1", _
TextToDisplay:=NameDevice
End If
Next
End If
Next
Application.ScreenUpdating = True
shtsumm.Activate
End Sub
How can I modify the execution of the vlookup based upon a specific value. I want it to execute the Vlookup only if the output sheet (sheet 2) cell (Q2 to AB2) contains "Forecast" otherwise skip column if labeled "Actual" in the relative cell.
Finally I want to copy and paste any cells in the Column Q to AB that contain the vlookup forumla. I believe this can be accomplished using the String function.
Sub MakeFormulas()
Dim SourceLastRow As Long
Dim OutputLastRow As Long
Dim sourceSheet As Worksheet
Dim outputSheet As Worksheet
Dim X As Long
'names of our worksheets
Set sourceSheet = Worksheets("Sheet1")
Set outputSheet = Worksheets("Sheet2")
'Determine last row of source
With sourceSheet
SourceLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
With outputSheet
'Determine last row in col C
OutputLastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
For X = 2 To OutputLastRow
If InStr(1, .Range("C" & X), "PO Materials") + InStr(1, .Range("C" & X), "PO Labor") > 0 Then
'Apply formula
.Range("Q" & X & ":AB" & X).Formula = _
"=VLOOKUP($E" & X & ",'" & sourceSheet.Name & "'!$A$2:$L$" & SourceLastRow & ",Match(Q$1,'" & sourceSheet.Name & "'!$A$1:$AD$1,0),0)"
End If
Next
End With
End Sub
Sheet 2 Screenshot
I will just hardcode a bit:
For Y = 17 To 28 'Q to AB
For X = 2 To OutputLastRow
If InStr(1, .Range("C" & X), "PO Materials") + InStr(1, .Range("C" & X), "PO Labor") > 0 And Cells(2, Y) = "Forecast" Then
'Apply formula
.Cells(X, Y).Formula = _ 'cell at row X, column Y
"=VLOOKUP($E" & X & ",'" & sourceSheet.Name & "'!$A$2:$L$" & SourceLastRow & ",Match(" & cells(1,Y).address & ",'" & sourceSheet.Name & "'!$A$1:$AD$1,0),0)"
End If
Next
Next
It breaks down to check the second cell in each column first before applying the formula