I have a worksheet (named RsOut) with 235 columns. I need to overwrite the values in only certain columns with data from another sheet(named rsTrans). Both sheets have a unique identifier that I am using to match.
I decided to use the Sumif function to populate the rsOut worksheet. Where I ran into a snag is I cannot figure out how to run the script for all rows in the column that have data.
Once we figure this out, I need to repeat this process for roughly 15 other columns.
My over-arching question is even after we get the sumif to work properly, what is the most efficient way to execute the code so that it repeats 15 more times?
The Criteria list and the CriteriaRange will always have the same location. But the Sum Range and the column where the results are inserted will change for each of the 15 columns.
So, Thoughts on the most efficient way to proceed...maybe separate the sumif code as it's own block and call upon it instead of repeating the steps over and over, and/or list out all the sum ranges and all the insert ranges, so the script just loops through them..Would love your insight VBA masters.
Issue:
I think my main issue is that I tried to use a rngList as the criteria.
I also tried to separate the sumif as a separate block of code, to call on. I may have screwed something up there as well.
The error highlights on the Set sumRange row. (Runtime error 1004 - Method 'Range' of Object '_Worksheet' Failed.
Any help you can provide would be greatly appreciated!!
Sub SumifmovewsTransdatatowsOut()
Dim wb As Workbook, wsOut As Worksheet
Dim wsTrans As Worksheet, rngList As Range
Dim sumRange As Range
Dim criteriaRange As Range
Dim criteria As Long 'Setting as long because the IDs (criteria) are at least 20 characters. Should this be a range??
Set wb = ThisWorkbook
Set wsTrans = Worksheets("DEL SOURCE_Translator") 'Worksheet that contains analysis and results that need to be inserted into wsOut
Set wsOut = Worksheets("FID GDMR - Output_2") 'Worksheet where you are pasting results from wsTrans
Set rngList = wsOut.Range("B2:B" & wsOut.Cells(Rows.Count, "B").End(xlUp).Row) 'this range of IDs will be different every run, thus adding in the count to find last row...or do I not need the rnglist at all? Just run the sumif for all criteria B2:b
Set sumRange = wsTrans.Range("ag21:ag") 'Values in wsTrans that need to be added to wsOut
Set criteriaRange = wsTrans.Range("AA21:AA") 'Range of IDs found on wsTrans
criteria = rngList
Sumif
End Sub
'Standard Sumif formula
Sub Sumif()
wsOut.Range("AT2:AT") = WorksheetFunction.SumIfs(sumRange, criteriaRange, criteria)
End Sub
'OR should the Sumif formula be: rng.Formula = "=SUMIF(criteriaRange,rngList,sumRange)"
SUBSEQUENT TESTING after receiving recommendations:
I tested using the second recommendation only because a future user could easily change out the array values if the columns shifted on the wsout template. Below is the code that I used and the resulting error.
Result issues:
the result in each changed cell is #NAME?
a pop up box shows up for each request. It is looking for the translater. See screenshot below. If I x out of each pop up box, the script completes and each cell has the #NAME?
enter image description here
Thoughts on what went wrong?
Code:
Sub test2()
Dim wsTrans As Worksheet: Dim wsOut As Worksheet
Dim rgCrit As String: Dim rgSum As String
Dim rgR As Range: Dim i As Integer: Dim arr
arr = Array("AG:AT", "AJ:BB", "AM:BJ", "AT:BR", "AZ:CA", "BP:DE", "BW:DO") 'change as needed
Set wsTrans = Sheets("DEL SOURCE_Translator") 'change as needed
Set wsOut = Sheets("FID GDMR - Output_2") 'change as needed
rgCrit = wsTrans.Name & "!" & wsTrans.Columns(27).Address 'Column 27 is AA in wsTrans which contains the criteria range
Set rgR = wsOut.Range("B2", wsOut.Range("B2").End(xlDown)) 'change as needed
startCell = "$" & Replace(rgR(1, 1).Address, "$", "")
For i = LBound(arr) To UBound(arr)
rgSum = wsTrans.Name & "!" & Split(arr(i), ":")(0) & ":" & Split(arr(i), ":")(0)
With rgR.Offset(0, Range(Split(arr(i), ":")(1) & 1).Column - rgR.Column)
.Value = "=SUMIF(" & rgCrit & "," & startCell & "," & rgSum & ")"
.Value = .Value
End With
Next
End Sub
'Sum Ranges in wsTrans: AG, AJ, AM, AT, AZ, BP, BW
'Result Columns in wsOut: AT, BB, BJ, BR, CA, DE, DO
Additional Review:
Also, to test, instead of x'ing out of the pop up, I selected my file in the pop up. when I did, a second pop up below showed up. Interestingly, the sheet name is missing the DEL on the front. When I select the correct sheet, I still get the #Name? error.
enter image description here
Okay, so your question is a little too broad for this website. The general rule is each question should address one specific issue.
That being said, I think I can help you with a few easy to solve points.
1) Making Sumif Work:
Using Sumif() function inside a Sub is the same as using it in an Excel formula. First you need two full ranges, next you need a value to lookup.
Full ranges: wsTrans.Range("ag21:ag") is not going to work because it doesn't have an end row. Instead, it needs to be wsTrans.Range("AG21:AG100"). Now since you don't seem to know your last row, I would suggest you find that first and then integrate it into all your ranges. I'm using the variable lRow below.
Option Explicit
Sub TestSum2()
Dim WB As Workbook
Dim wsTrans As Worksheet
Dim wsOut As Worksheet
Dim criteriaRange As Range
Dim sumRange As Range
Dim rngList As Range
Dim aCriteria 'Array
Dim lRow As Long
Set WB = ThisWorkbook
Set wsTrans = WB.Worksheets("DEL SOURCE_Translator")
Set wsOut = WB.Worksheets("FID GDMR - Output_2")
lRow = wsOut.Range("B" & Rows.Count).End(xlUp).Row
Set rngList = wsOut.Range("B2:B" & lRow)
aCriteria = rngList 'Transfer Range to array
lRow = wsTrans.Range("AA" & Rows.Count).End(xlUp).Row
Set sumRange = wsTrans.Range("AG21:AG" & lRow)
Set criteriaRange = wsTrans.Range("AA21:AA" & lRow)
Debug.Print Application.WorksheetFunction.SumIf(criteriaRange, aCriteria(1, 1), sumRange)
End Sub
The above sub returns:
Which is correct considering the following sheets:
2) Making it loop through the criteria list
You've already made a great start on looping through this criteria list by importing rngList into an array. Next we just need to loop that array like so:
Option Explicit
Sub TestSum2()
Dim WB As Workbook
Dim wsTrans As Worksheet
Dim wsOut As Worksheet
Dim criteriaRange As Range
Dim sumRange As Range
Dim rngList As Range
Dim aCriteria 'Array
Dim lRow As Long
Dim I As Long
Set WB = ThisWorkbook
Set wsTrans = WB.Worksheets("DEL SOURCE_Translator")
Set wsOut = WB.Worksheets("FID GDMR - Output_2")
lRow = wsOut.Range("B" & Rows.Count).End(xlUp).Row
Set rngList = wsOut.Range("B2:B" & lRow)
aCriteria = rngList 'Transfer Range to array
lRow = wsTrans.Range("AA" & Rows.Count).End(xlUp).Row
Set sumRange = wsTrans.Range("AG21:AG" & lRow)
Set criteriaRange = wsTrans.Range("AA21:AA" & lRow)
For I = 1 To UBound(aCriteria, 1)
Debug.Print "Sum of " & aCriteria(I, 1) & "=" & _
Application.WorksheetFunction. _
SumIf(criteriaRange, aCriteria(I, 1), sumRange)
Next I
End Sub
This results in an output of:
Then to finish it off, you'll need to check which column to put it in, maybe with a .Find or maybe with a Match() of the column headers, but I don't know what your data looks like. But, if you just want to output that range to your output sheet here's how to do that:
Sub TestSum2()
Dim WB As Workbook
Dim wsTrans As Worksheet
Dim wsOut As Worksheet
Dim criteriaRange As Range
Dim sumRange As Range
Dim rngList As Range
Dim aCriteria 'Array
Dim OutputSums
Dim lRow As Long
Dim I As Long
Set WB = ThisWorkbook
Set wsTrans = WB.Worksheets("DEL SOURCE_Translator")
Set wsOut = WB.Worksheets("FID GDMR - Output_2")
lRow = wsOut.Range("B" & Rows.Count).End(xlUp).Row
Set rngList = wsOut.Range("B2:B" & lRow)
aCriteria = rngList 'Transfer Range to array
lRow = wsTrans.Range("AA" & Rows.Count).End(xlUp).Row
Set sumRange = wsTrans.Range("AG21:AG" & lRow)
Set criteriaRange = wsTrans.Range("AA21:AA" & lRow)
ReDim OutputSums(1 To UBound(aCriteria, 1), 1 To 1)
For I = 1 To UBound(aCriteria, 1)
OutputSums(I, 1) = Application.WorksheetFunction. _
SumIf(criteriaRange, aCriteria(I, 1), sumRange)
Next I
wsOut.Range("C2").Resize(UBound(OutputSums, 1), 1) = OutputSums
End Sub
Resulting in:
If I understand you correctly, besides Mr. Cameron's answers, another way maybe you can have the VBA using formula.
Before running the sub is something like this :
After running the sub (expected result) is something like this:
Please ignore the fill color, the sorting and the value, as they are used is just to be easier to calculate manually for the expected result.
The Criteria list and the CriteriaRange will always have the same
location. But the Sum Range and the column where the results are
inserted will change for each of the 15 columns.
Since you don't mention where are the columns for the Sum Range will be, this code assume that it will be in a consecutive column to the right of column ID, as seen in the image of sheet1 ---> rgSUM1, rgSUM2, rgSUM3.
And because you also don't mention in what column in sheet2 the result is, this code assume that it will be in a consecutive column to the right of column ID, as seen in the image of sheet2 ---> SUM1, SUM2, SUM3.
If your Sum Range columns are random and/or your Sum Result columns are random, then you can't use this code. For example : your rgSum1 is in column D sheet1 - rgSum1Result sheet2 column Z, rgSum2 is in column AZ sheet1 - rgSum2Result sheet2 column F, rgSum3 is in column Q sheet1 - rgSum3Result sheet2 column DK, and so on until 15 columns. I think it will need an array of column letter for both rgSum and rgSumResult if they are random.
Sub test()
Dim sh1 As Worksheet: Dim sh2 As Worksheet
Dim rgCrit As String: Dim rgSum As String
Dim rgR As Range: Dim col As Integer
col = 3 'change as needed
Set sh1 = Sheets("Sheet1") 'change as needed
Set sh2 = Sheets("Sheet2") 'change as needed
rgCrit = sh1.Name & "!" & sh1.Columns(1).Address 'change as needed
rgSum = sh1.Name & "!" & Replace(sh1.Columns(2).Address, "$", "") 'change as needed
Set rgR = sh2.Range("A2", sh2.Range("A2").End(xlDown)) 'change as needed
startCell = "$" & Replace(rgR(1, 1).Address, "$", "")
With rgR.Resize(rgR.Rows.Count, col).Offset(0, 1)
.Value = "=SUMIF(" & rgCrit & "," & startCell & "," & rgSum & ")"
.Value = .Value
End With
End Sub
Basically the code just fill the range of the expected result with SUMIF formula.
col = how many columns are there as the sum range
sh1 (wsTrans in your case) is the sheet where the ID and the multiple sum range are.
sh2 (wsOut in your case) is the sheet where the ID to sum and the multiple sum result are.
rgCrit is the sh1 name with the column of the range of criteria (column A, (ID) in this case)
rgSum is the sh1 name with the first column of Sum Range (column B in this case)
rgR is the range of the unique ID in sheet2 (column A in this case, must have no blank cell in between, because it use xldown) and finally, startCell is the first cell address of rgR
Below if the SumRange and ResultRange are random column.
Sub test2()
Dim sh1 As Worksheet: Dim sh2 As Worksheet
Dim rgCrit As String: Dim rgSum As String
Dim rgR As Range: Dim i As Integer: Dim arr
arr = Array("B:G", "F:E", "D:B") 'change as needed
Set sh1 = Sheets("Sheet13") 'change as needed
Set sh2 = Sheets("Sheet14") 'change as needed
rgCrit = sh1.Name & "!" & sh1.Columns(1).Address 'change as needed
Set rgR = sh2.Range("A2", sh2.Range("A2").End(xlDown)) 'change as needed
startCell = "$" & Replace(rgR(1, 1).Address, "$", "")
For i = LBound(arr) To UBound(arr)
rgSum = sh1.Name & "!" & Split(arr(i), ":")(0) & ":" & Split(arr(i), ":")(0)
With rgR.Offset(0, Range(Split(arr(i), ":")(1) & 1).Column - rgR.Column)
.Value = "=SUMIF(" & rgCrit & "," & startCell & "," & rgSum & ")"
.Value = .Value
End With
Next
End Sub
The arr value is in pair : sum range column - sum result column.
Example arr in code :
First loop : sum range column is B (sheet1) where the result will be in column G (sheet2).
Second loop: sum range column is F (sheet1) where the result will be in column E (sheet2).
Third loop: sum range column is D (sheet1) where the result will be in column B (sheet2).
I am trying to use Index and Match to lookup a value on another worksheet within the same workbook, but I keep getting an error returned. (error 2042) I know I can do this using a formula, (see pic) but I'd like to use code. Does anyone mind taking a look?
Dim WorkOrderDashboardCell As Range
Dim ProjectList As Worksheet
Dim ProjectNumber As String
Set ProjectList = Worksheets("Project List")
ProjectList.Activate
'We need to start by initializing values on the project list
With ProjectList
Dim LastRowProjectListSpreadsheet As Long
LastRowProjectListSpreadsheet = .Range("B" & Rows.Count).End(xlUp).Row
Dim ProjectListNumbers As Range
Set ProjectListNumbers = .Range("B2:B" & LastRowProjectListSpreadsheet)
Dim ProjectListProjectNumber As Integer
ProjectListProjectNumber = 2
End With
'Switch back to the Dashboard spreadsheet
DashBoard.Activate
Dim DashboardWorkOrderRange As Range
Set DashboardWorkOrderRange = DashBoard.Range("E17:E" & LastRowProjectListSpreadsheet)
For Each WorkOrderDashboardCell In Range("E17:E" & Rows.Count).End(xlUp).Row
ProjectNumber = Application.Index(ProjectListNumbers, Application.Match(WorkOrderDashboardCell, DashboardWorkOrderRange, 0))
Debug.Print ProjectNumber
Next
To use worksheet functions, use code like:
WorksheetFunction.Index
rather than:
Application.Index
You might also need to use the Address property of your ranges, like:
ProjectListNumbers.Address
I think this line here is incorrect:
For Each WorkOrderDashboardCell In Range("E17:E" & Rows.Count).End(xlUp).Row
You are trying to loop within a range, but this part of the aforementioned line returns a row number not a range of cells:
Range("E17:E" & Rows.Count).End(xlUp).Row
Change it to a range of cells.
Application.Match
In your code you are using
Set DashboardWorkOrderRange = DashBoard.Range("E17:E" & LastRowProjectListSpreadsheet) where LastRowProjectListSpreadsheet is possibly the wrong last row. Also you are using
For Each WorkOrderDashboardCell In Range("E17:E" & Rows.Count).End(xlUp).Row where Range("E17:E" & Rows.Count).End(xlUp).Row is a row (instead of a range). Finally you are using Application.Filter without testing the result of Application.Match. Some other issues are the unnecessary use of Activate and the use of long variable names the latter seriously affecting the readability of the code.
This is your code revised. When running it you will see that it makes little sense (mentioned in the comments).
I'm posting it for you only to maybe easier find out what you really want to do.
It is illustrating how the result of Application.Match should always be tested with IsNumeric (or IsError) and that you don't have to (in this case, should not) use Application.Index, but just the Cells property of the range object with the index returned by Application.Match, to return the desired value.
The Code
Option Explicit
Sub LittleSense()
Dim wb As Workbook: Set wb = ThisWorkbook ' Workbook containing this code.
Dim LastRow As Long
Dim plRng As Range
With wb.Worksheets("Project List")
LastRow = .Range("B" & .Rows.Count).End(xlUp).Row
Set plRng = .Range("B2:B" & LastRow)
End With
Dim dbRng As Range
With wb.Worksheet("Dashboard")
LastRow = .Range("E" & .Rows.Count).End(xlUp).Row
dbRng = .Range("E17:E" & LastRow)
End With
Dim cel As Range
Dim dbIndex As Variant
Dim plValue As Variant
For Each cel In dbRng.Cells
dbIndex = Application.Match(cel, dbRng, 0)
' You might as well do:
'dbIndex = dbIndex + 1
If IsNumeric(dbIndex) Then ' Not necessary: all values will be found.
plValue = plRng.Cells(dbIndex).Value
Debug.Print plValue & " (" & dbIndex & ")"
Else
' Not necessary: all values will be found.
Debug.Print "Not found " & "(""" & cel.Value & """)"
End If
Next cel
End Sub
I am trying to upload the data to the destination workbook from the source workbook.
Let's assume I have 15-20 rows of data.
There are two conditions:
When the frmData.txtdate.Value (textbox value from the userform) is = to the destination workbook's cell value, then there will be a MsgBox displaying that the data is already copied. Also I want that if this gets executed then the destination workbook should get closed.
When the frmData.txtdate.Value (textbox value from the userform) is = to the source workbook's cell value , then the whole data from range A2:T999 would get copied and pasted to the destination workbooks range A:Lastrow
But when I try doing it, all the 15-20 rows get duplicated and copied for 15-20 times below each other.
The code is as follows:
Private Sub Upload()
Dim SourceWB As Workbook
Dim SourceWs As Worksheet
Dim DesWB As Workbook
Dim DesWs As Worksheet
Dim DateRange As Range
Dim DesDataRange As Range
Dim LastRowCount As Long 'Upload Button Value
Dim DesLastRow As Long
Dim Ls As Long
Dim Y As Long
Set SourceWB = ThisWorkbook
Set SourceWs = SourceWB.Worksheets("Database")
Set DesWB = ActiveWorkbook
Set DesWs = DesWB.ActiveSheet
LastRowCount = SourceWs.Range("D" & Rows.count).End(xlUp).Row
DesLastRow = DesWs.Range("D" & Rows.count).End(xlUp).Row
Set DateRange = SourceWs.Range("D2", "D" & LastRowCount)
Set DesDateRange = DesWs.Range("D2", "D" & DesLastRow)
'Check Destination File for Similar Date
For Each Cell In DesDateRange
If Cell.Value = frmData.txtdate.Value Then
MsgBox "Data Already Colated, If you want To make any Changes Contact your SME Or Admin"
Exit Sub
End If
Next Cell
'Paste Similar Date Values to destination file
'*The problem starts here*
For Each Cell In DateRange
If Cell.Value = frmData.txtdate.Value Then
'Y = Cell.Row 'Cells(y, 1), Cells(y, 20)
SourceWs.Range("A" & 2, "T" & LastRowCount).Copy
Workbooks(FileNameValue).Activate
Ls = ActiveWorkbook.Worksheets("Sheet1").Range("A" & Rows.count).End(xlUp).Row
ActiveWorkbook.Worksheets("Sheet1").Range("A" & Ls + 1).PasteSpecial Paste:=xlPasteValues 'AndNumberFormats
End If
Next
ActiveWorkbook.Save
ActiveWorkbook.Close
End Sub
In that last for-loop you are:
Going through each cell in a column of SourceWS
For Each Cell In DateRange
Each time copying the whole Source Range
If Cell.Value = frmData.txtdate.Value Then
SourceWs.Range("A" & 2, "T" & LastRowCount).Copy
Workbooks(FileNameValue).Activate
Ls = ActiveWorkbook.Worksheets("Sheet1").Range("A" & Rows.count).End(xlUp).Row
ActiveWorkbook.Worksheets("Sheet1").Range("A" & Ls + 1).PasteSpecial Paste:=xlPasteValues 'AndNumberFormats
End If
Therefore, if more than one cell in DateRange equal the value in txtdate, the whole SourceRange will be copyied (that many times).
So the result you are describing is exactly what is coded.
Now if you want to copy the range only once you have two options:
a) Easiest with the code you have: add an Exit For within right after pasting the range.
b) Best Practice: instead of the For each Cell in DateRange loop, do something like:
Dim rn_found
Set rn_found = DateRange.find(frmData.txtdate.Value)
If Not rn_found Is Nothing Then
'... do your thing
End If
I'm beginner at Macros I need to do a copy of rows but I have to exclude some columns. EntireRow is working but I need to exclude the columns I,G,H
Sub Macro1()
Dim RngToChk as Range, RngToPaste as Range
Set RngToCheck=Application.InputBox(Prompt:="enter range", Type:=8)
Dim strtofind as String
Inttofind=InputBox("Give your Indicator")
Dim i as long
For i = RngToChk.Rows.Count To 1 Step -1
If RngToChk(i).value=strtofind Then
RngToCheck(i).Offset(1).EntireRow.Insert
Set RngToPaste=RngToChk(i).Offset(1)
RngToPaste.EntireRow.Value=RngToChk(i).EntireRow.Value
RngToPaste.EntireRow.Font.Color=RGB(255,0,0)
End If
Next i
End Sub
Add this function to your module:
Function AlmostEntireRow(StartingPoint As Range) As Range
Dim Row As Long
Dim TargetSheet As Worksheet
Row = StartingPoint.Row
Set TargetSheet = StartingPoint.Worksheet
Set AlmostEntireRow = Union(TargetSheet.Range("A" & Row & ":F" & Row), TargetSheet.Range("J" & Row & ":GR" & Row))
End Function
When you are using it, replace
RngToPaste.EntireRow.Font.Color=RGB(255,0,0)
with
AlmostEntireRow(RngToPaste).Font.Color = RGB(255, 0, 0)
and so on.
The function builds a range from the input range, consisting of columns A to F and J to GR. Adjust as needed.
Update
The suggested method does not work when copying rows. Here is a copy method as well.
Sub CopyAlmostEntireRow(FromRow As Range, ToRow As Range)
Dim FromRange As Range
Dim ToRange As Range
Set FromRange = FromRow.Worksheet.Range("A" & FromRow.Row & ":F" & FromRow.Row)
Set ToRange = ToRow.Worksheet.Range("A" & ToRow.Row & ":F" & ToRow.Row)
ToRange.Value = FromRange.Value
Set FromRange = FromRow.Worksheet.Range("J" & FromRow.Row & ":GR" & FromRow.Row)
Set ToRange = ToRow.Worksheet.Range("J" & ToRow.Row & ":GR" & ToRow.Row)
ToRange.Value = FromRange.Value
End Sub
' Call with something like this:
CopyAlmostEntireRow RngToChk(i), RngToPaste
I'm trying to make a program in the Excel VBA that inserts a formula into a column of cells. This formula changes based on the contents of the cell directly to the left.
This is the code I have written so far:
Sub Formula()
Dim colvar As Integer
colvar = 1
Dim Name As String
Name = "Sample, J."
Do While colvar <= 26
colvar = colvar + 1
Name = Range("B" & colvar).Value
Range("C" & colvar).Value = "='" & Name & "'!N18"
Loop
End Sub
As you can see, I want to insert the variable Name between the formula strings, but Excel refuses to run the code, giving me a "application-defined or object-defined error."
Is there a way to fix this?
You will need some error checking in case the sheets don't actually exist in the workbook.
it looks like you are looping through column B that has a list of sheet names and want range N18 to display next to it.
Something like
Sub Button1_Click()
Dim Lstrw As Long, rng As Range, c As Range
Dim Name As String
Lstrw = Cells(Rows.Count, "B").End(xlUp).Row
Set rng = Range("B1:B" & Lstrw)
For Each c In rng.Cells
Name = c
c.Offset(, 1) = "='" & Name & "'!N18"
Next c
End Sub
Or you can just list the sheets and show N18 next to it, run this code in a Sheet named "Sheet1"
Sub GetTheSh()
Dim sh As Worksheet, ws As Worksheet
Set ws = Sheets("Sheet1")
For Each sh In Sheets
If sh.Name <> ws.Name Then
ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1) = sh.Name
ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(0, 1) = sh.Range("N18")
End If
Next sh
End Sub
Thank you to everyone for your help! I actually found that I had just made a silly error: the line Do While colvar<=26 should have been Do While colvar<26. The cells were being filled, but the error manifested because one cell was being filled by a nonexistent object.
I did decide to use the .Formula modifier rather than .Value. Thank you to Jeeped for suggesting that.