I am trying to assign each of the ID's you see in column E and F of ws4 here...
...to the respective ID on my wsOutput in column K and L, respectively.
My code runs through without an Error but nothing happens. This is one of my first projects, so I apologize if this is straight-forward question.
I also consulted the Internet and found:
http://answers.microsoft.com/en-us/msoffice/forum/msoffice_excel-mso_windows8/how-to-concatenate-multiple-rows-by-the-condition/fdd048ba-5405-4e53-b463-125f9cde2c0c?auth=1
http://www.eileenslounge.com/viewtopic.php?f=27&t=12298
However, I wasn't able to get their approaches working.
Any help is greatly appreciated!
'Previous Code
'wsOutput -> Filter Sheet - Worksheet (TARGET) ; ws4 = Search Skills - Worksheet (SOURCE)
Dim separator As String, PreviousResultCG As String, NewResultCG As String, PreviousResultCategory As String, NewResultCategory As String
If separator = "" Then separator = " , "
'lRowInput = ws4.Range("A" & Rows.Count).End(xlUp).row - from above
lRowOutput = wsOutput.Range("A4:A" & Rows.Count).End(xlDown).row
With ws4
'For each ID on the Source-Worksheet
For Each ID In .Range("A2:A" & lRowInput)
'Find the respective ID on Target-Worksheet
Set FindID = wsOutput.Range("A4:A" & lRowOutput).Find(what:=ID, LookIn:=xlValues, lookat:=xlWhole)
'Get all CG ID's for the supplier and add them to previously found ID's of that supplier
If FindID = ID Then
PreviousResultCG = wsOutput.Range("K" & FindID.row).value
NewResultCG = PreviousResultCG & separator & .Range("E" & ID.row)
wsOutput.Range("K" & ID.row).value = NewResultCG
PreviousResultCategory = wsOutput.Range("L" & FindID.row).value
NewResultCategory = PreviousResultCategory & separator & .Range("F" & ID.row)
wsOutput.Range("L" & FindID.row).value = NewResultCategory
End If
Next ID
End With
Place source data in sheet named "source" and create another sheet where you want to lookup values from source data named as "target". Keep columns as you shown in images.
paste below mentioned code in module.
Sub look_values()
Dim id, source_id As Range
Dim data_row_num, id_row_num As Long
Dim source_sheet, target_sheet As Worksheet
Dim cg, cat As String
Set source_sheet = ThisWorkbook.Sheets("source")
Set target_sheet = ThisWorkbook.Sheets("target")
Set id = target_sheet.Range("A2")
Do Until id.Value = ""
source_sheet.Activate
Range("A1").Activate
Set source_id = Range("A:A").Find(what:=id.Value, LookIn:=xlValues, lookat:=xlWhole)
On Error Resume Next
cg = Cells(source_id.Row, 5).Value
On Error Resume Next
cat = Cells(source_id.Row, 6).Value
target_sheet.Activate
Cells(id.Row, 11).Value = cg
Cells(id.Row, 12).Value = cat
Set id = id.Offset(1, 0)
Loop
End Sub
Before running the macro, make sure that the format of ID column on both sheets are same. Will suggest you to First Clean & Trim the ID Column. Because it is visible in the image that ID column in target sheet has unrecognized characters.
Related
This question already has answers here:
PowerQuery: How can I concatenate grouped values?
(3 answers)
Closed 4 years ago.
I am very new to excel macros and i need your help to fix one of my condition based concatenation problem.
i will explain the problem with simple scenario in below:
In my sheet , Column A contains customer name and Column B contains country names. Attached excel screenprint for reference ( column C and Column D will be my expected results)
In the column A, single customer name can be repeated as he can have multiple country representations
In the column B, countries placed as shown in the screenprint.
My expected results will be look alike in the column C and D as shown in the image.
I can do the column C using INDEX and i am able to get the unique values from column A
For the column D ,i am expecting the results in such a way that all countries will be concatenated and separated by ' / ' based on the corresponding customer in column A. I tried some vlookups and indexes, but i am unable
to do it.
it would be really helpful if you could provide any suggestions(function/Macros) how it will be achieved.
I am a lower intermediate vba user, so I will admit that I am sure someone can do this better than , however, this works. Add a button and then click on it, or add this to the worksheet and it will occur whenever you choose for it to be fired:
Option Explicit
Sub listout()
'declare your variables
Dim wbk As Workbook
Dim ws1 As Worksheet
Dim cprange As Range
Dim rmrange As Range
Dim bottomRow As Long
Dim row As Range
Dim countname As Variant
Dim copyname As Variant
Dim nametoRow As Long
'speed up process
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
'set what the variables are
Set wbk = ThisWorkbook
Set ws1 = wbk.Worksheets("Names List")
bottomRow = ws1.Range("A1").End(xlDown).row
'get ird of any excisting values
ws1.Range("C1:D100").ClearContents
'Set the range of the names that you want to copy, and put them into column C
Set cprange = ws1.Range(Range("A1"), Range("A1" & bottomRow))
ws1.Range(Range("C1"), Range("C1" & bottomRow)) = cprange.Value
'then remove all the duplicates
Set rmrange = ws1.Range(Range("C1"), Range("C1" & bottomRow))
rmrange.RemoveDuplicates Columns:=1, Header:=xlNo
'redclare the range as it will be shorter because you got rid of load sof duplicates
Set rmrange = ws1.Range(Range("C1"), Range("C1").End(xlDown))
'loop though each name in the 'unique' list and loop through their names in the original data then add the country to their new location in column D
For Each copyname In rmrange
For Each row In cprange
nametoRow = ws1.Application.WorksheetFunction.Match(copyname, rmrange, False)
countname = row.Offset(0, 1)
If row.Value = copyname Then
If Trim(ws1.Range("D" & nametoRow) & vbNullString) = vbNullString Then
ws1.Range("D" & nametoRow) = countname
Else
ws1.Range("D" & nametoRow) = ws1.Range("D" & nametoRow) & "/ " & countname
End If
End If
Next row
Next copyname
'turn these back on otherwise it messes with your computer/excel
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Here is a more efficient method.
Advanced Filter to remove duplicates from Col A, paste on Col C
Set necessary ranges
Loop through each unique name
Build String
Paste String
Loop 4 - 6 until complete
Assumptions/Actions: You have headers on Col A, B, C, & D. If you have duplicate countries for a person, the country will show up twice on the string.You will need to change "Sheet1" to your sheet name on the 3rd line.
Usually you would need to check if your value is found using the .Find method, but the below logic does not allow for a cell to not be found as it is looping through values determined by filter. It wouldn't make since for a filtered object to not be found in the range it came from.
Option Explicit
Sub CountryList()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim FoundCell As Range, SearchRange As Range, Names As Range, SearchCell As Range
Dim MyString As String, i As Long
Set SearchRange = ws.Range("A2:A" & ws.Range("A" & ws.Rows.Count).End(xlUp).Row)
SearchRange.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Range("C2"), Unique:=True
ws.Range("C2").Delete Shift:=xlShiftUp
Set Names = ws.Range("C2:C" & ws.Range("C" & ws.Rows.Count).End(xlUp).Row)
For Each SearchCell In Names
Set FoundCell = SearchRange.Find(SearchCell)
For i = 1 To Application.WorksheetFunction.CountIf(SearchRange, SearchCell)
MyString = MyString & FoundCell.Offset(, 1) & "/"
Set FoundCell = SearchRange.FindNext(FoundCell)
Next i
SearchCell.Offset(, 1) = Left(MyString, Len(MyString) - 1)
MyString = ""
Next SearchCell
End Sub
I am having a fair amount of trouble with the code below:
Sub TestEmail()
Dim i As Long
Dim LastRow As Long
Dim a As Worksheet
Dim b As Worksheet
Dim strText
Dim ObjData As New MSForms.DataObject
Set a = Workbooks("Book2").Worksheets(1)
Set b = Workbooks("Book1").Worksheets(1)
LastRow = a.Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
If Not IsError(Application.Match(a.Cells(i, 7).Value, b.Columns(3), 0)) And IsError(Application.Match(a.Cells(i, 4).Value, b.Columns(11), 0)) Then
a.Range("D" & i).Copy
ObjData.GetFromClipboard
strText = Replace(ObjData.GetText(), Chr(10), "")
b.Range("K" & ).Value = b.Range("K" & ).Value & " / " & strText
End If
Next i
End Sub
I face two problems, one has me stumped and the other is due to lack of knowledge:
The line after IF is supposed to check if two values (numbers) in both workbooks match, and if two other values (text) don't match. If all true, then it must copy a value from Book2 and add it to a cell in book1.
The problems are:
-The macro doesn't seem to recognise when the values match or not.
-In the last line before "End If", I don't know how to tell excel to copy the text into the cell that didn't match in the second check.
I am sorry if I am not clear enough, this is hard to explain.
I'm hoping one of the experts knows how to make this work.
Thanks in advance
You are using If Not condition 1 And condition 2, so you are saying that if it doesn't match both conditions, Then you run the code. What you want to make are Nested If Statements However, one is If and the other If Not
To copy you are missing the i After "K"&: b.Range("K" & i) = b.Range("K" & i).Value & " / " & strText
The Address of the Cells are inside the Range Function, which in your case would be:
//It is the cell of the email from the first Workbook tou are copying, where you input the column D
a.Range("D" & i).Copy
//Add to Workbook b in column K the value from Cell K#/value copied
b.Range("K" & i) = b.Range("K" & i).Value & " / " & strText
You can also make it like this: b.Range("K" & i) = b.Range("K" & i).Value & " / " & a.Range("D" & i)
This way you are matching lines, so only if the IDs are on the same rows on both Workbooks it will work. If they aren't, you will have to use Nesting Loops or .Find Function
EDIT:
If I understood it, the code below might work if you make some changes for your application, because i didn't have the data to test and columns, etc. Try to implement it.
LastRowa = a.Cells(Rows.Count, "A").End(xlUp).Row
LastRowb = b.Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRowa
'Address of String to look for
LookForString = a.Worksheets(1).Cells(i, 4) '4 is the COLUMN_INDEX
'Range to look on Workbook a
With a.Worksheets(1).Range("D1:D" & LastRowa) 'choose column to look
'Function .Find String on book a
Set mail_a = .Find(LookForString, LookIn:=xlValues)
If Not mail_a Is Nothing Then
FirstAddress = mail_a.Address
Do ' Actions here
'Range to look on Workbook b
With b.Worksheets(1).Range("K1:K" & LastRowb) 'choose column to look
'Function .Find on Workbook b
Set mail_b = .Find(LookForString, LookIn:=xlValues)
If Not mail_b Is Nothing Then
FirstAddress = mail_b.Address
Do 'Actions
'Verify if two other values (text) don't match
If Not WRITE_MATCH_CONDITION_HERE Then
'No need to verify of they are equal because the .Find function used the same reference
'I will use .Cells with .Row and .Column just to show another way to do it and make it dynamic
b.Cells(mail_b.Adress.Row, mail_b.Adress.Column) = b.Cells(mail_b.Adress.Row, mail_b.Adress.Column).Value & " / " & a.Cells(mail_a.Adress.Row, mail_a.Adress.Column) 'choose columns
End If
Set mail_b = .FindNext(mail_b)
Loop While Not mail_b Is Nothing And mail_b.Address <> FirstAddress
End If
End With
Set mail_a = .FindNext(mail_a)
Loop While Not mail_a Is Nothing And mail_a.Address <> FirstAddress
End If
End With
Next i
End Sub
p.s.: The <> is missing on mail_a.Address <> FirstAddress and mail_b.Address <> FirstAddress, when i posted with
I'm quite new at VBA. I've used it in excel for a couple macros, but this one is way above my head.
I'm looking to create a macro that will find the appropriate column, then based on the value in this columns, changes the values in three other columns. I already have a static macro:
Sub AdjustForNoIntent()
'Adjusts columns Role(U) (to C-MEM), REV Profile Follow-up Date(AJ) (to N/A) and deletes Follow-up Date(Y) when column Survey: Intent to Participate = No
Dim lastrow As Long
Dim i As Long
lastrow = Range("AE" & Rows.Count).End(xlUp).Row
For i = 2 To lastrow
If Not IsError(Range("AE" & i).Value) Then
If Range("AE" & i).Value = "No" And Range("U" & i).Value = "MEM" Then
Range("U" & i).Value = "C-MEM"
Range("Y" & i).ClearContents
Range("AJ" & i).Value = "N/A"
ElseIf Range("AE" & i).Value = "No" And Range("U" & i).Value = "VCH" Then
Range("U" & i).Value = "C-VCH"
Range("Y" & i).ClearContents
Range("AJ" & i).Value = "N/A"
End If
End If
Next i
End Sub
But this is a shared workbook, so people are adding columns randomly and every time I need to go back to the code and modify the columns refereces. What I want is, for instance, to look for column with "Role" header in row A3 and to insert it where the macro looks for column "U". That way other users can add/delete columns but I won't have to modify the macro every time.
In other macros, I manage to have this thing working:
Function fnColumnNumberToLetter(ByVal ColumnNumber As Integer)
fnColumnNumberToLetter = Replace(Replace(Cells(1,ColumnNumber).Address, "1", ""), "$", "")
End Function
Dim rngColumn As Range
Dim ColNumber As Integer
Dim ColName As String
ColName = "Email Address"
Sheets("Tracking").Select
Set rngColumn = Range("3:3").Find(ColName)
ColNumber = Sheets("Tracking").Range(rngColumn, rngColumn).Column
Sheets("Combined").Range(ActiveCell, "W2").FormulaLocal = "=IF(ISERROR(INDEX(Tracking!$A:$A,MATCH(O:O,Tracking!" & fnColumnNumberToLetter(ColNumber) & ":" & fnColumnNumberToLetter(ColNumber) & ",0))), INDEX(Tracking!$A:$A,MATCH(U:U,Tracking!" & fnColumnNumberToLetter(ColNumber) & ":" & fnColumnNumberToLetter(ColNumber) & ",0)), INDEX(Tracking!$A:$A,MATCH(O:O,Tracking!" & fnColumnNumberToLetter(ColNumber) & ":" & fnColumnNumberToLetter(ColNumber) & ",0)))"
However, I am unable to link the latter to the first and much less to get it to find multiple columns. Any help is appreciated.
EDIT:
Following suggestions, here is the new code. Doesn't return an error, but doesn't do anything either. It loops through the c loop ok, but jumps from For i =2 ... line to End Sub.
Sub Adjust()
Dim lastrow As Long
Dim i As Long
Dim headers As Dictionary
Dim c As Long
Set headers = New Scripting.Dictionary
For c = 1 To Cells(3, Columns.Count).End(xlToLeft).Column
headers.Add Cells(3, c).Value, c
Next c
lastrow = Cells(headers.Item("Survey: Interest to Participate") & Rows.Count).End(xlUp).Row
For i = 2 To lastrow
If Not IsError(Cells(i, headers.Item("Survey: Interest to Participate")).Value) Then
If Cells(i, headers.Item("Survey: Interest to Participate")).Value = "No" And Cells(i, headers.Item("Role")).Value = "MEM" Then
Cells(i, headers.Item("Role")).Value = "C-MEM"
Cells(i, headers.Ittem(" Follow-up date")).ClearContents
Cells(i, headers.Item("REV profile follow-up date")).Value = "N/A"
ElseIf Cells(i, headers.Item("Survey: Interest to Participate")).Value = "No" And Cells(i, headers.Item("Role")).Value = "VCH" Then
Cells(i, headers.Item("Role")).Value = "C-VCH"
Cells(i, headers.Ittem(" Follow-up date")).ClearContents
Cells(i, headers.Item("REV profile follow-up date")).Value = "N/A"
End If
End If
Next i
End Sub
The way I'd go about this would be to create a Dictionary with header names as keys and column numbers as values:
Dim headers As Dictionary
Set headers = New Scripting.Dictionary
Dim c As Long
'Assuming headers are in row 1 for sake of example...
For c = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
headers.Add Cells(1, c).Value, c
Next
Then, instead of using hard-code column letters with the Range, use the Cells collection and index it by column number using the Dictionary to look it up based on the header. For example, if your code expects column "U" to be under that header "Role" here:
Range("U" & i).Value = "C-MEM"
You can replace it with a column lookup like this using the Dictionary like this:
Cells(i, headers.Item("Role")).Value = "C-MEM"
Note that this requires a reference to the Microsoft Scripting Runtime (Tools->References... then check the box).
But this is a shared workbook, so people are adding columns randomly and every time I need to go back to the code and modify the columns refereces.
Protect the workbook to prevent this undesired behavior?
I would personally prefer to use Named Ranges, which will adjust with insertions and re-sorting of the data columns.
From Formulas ribbon, define a new name:
Then, confirm that you can move, insert, etc., with a simple procedure like:
Const ROLE As String = "Role"
Sub foo()
Dim rng As Range
Set rng = Range(ROLE)
' This will display $B$1
MsgBox rng.Address, vbInformation, ROLE & " located:"
rng.Offset(0, -1).Insert Shift:=xlToRight
' This will display $C$1
MsgBox rng.Address, vbInformation, ROLE & " located:"
rng.Cut
Application.GoTo Range("A100")
ActiveSheet.Paste
' This will display $A$100
MsgBox rng.Address, vbInformation, ROLE & " located:"
End Sub
So, I would define a Named Range for each of your columns (presently assumed to be AE, U, Y & AJ). The Named Range can span the entire column, which will minimize changes to the rest of your code.
Given 4 named ranges like:
Role, representing column U:U
RevProfile, representing column AJ:AJ
FollowUp, representing column Y:Y
Intent, representing column AE:AE
(NOTE: If you anticipate that users may insert rows above your header rows, then I would change the Named range assignments to only the header cells, e.g., "$AE$1", "$U$1", etc. -- this should require no additional changes to the code below)
You could do like this:
'Constant strings representing named ranges in this worksheet
Public Const ROLE As String = "Role"
Public Const REVPROFILE As String = "RevProfile"
Public Const FOLLOWUP As String = "FollowUp"
Public Const INTENT As String = "Intent"
Sub AdjustForNoIntent()
'Adjusts columns Role(U) (to C-MEM), REV Profile Follow-up Date(AJ) (to N/A) and deletes Follow-up Date(Y) when column Survey: Intent to Participate = No
Dim lastrow As Long
Dim i As Long
lastrow = Range(INTENT).End(xlUp).Row
For i = 2 To lastrow
If Not IsError(Range(INTENT).Cells(i).Value) Then
If Range(INTENT).Cells(i).Value = "No" And Range(ROLE).Cells(i).Value = "MEM" Then
Range(ROLE).Cells(i).Value = "C-MEM"
Range(FOLLOWUP).ClearContents
Range(REVPROFILE).Cells(i).Value = "N/A"
ElseIf Range(INTENT).Cells(i).Value = "No" And Range(ROLE).Cells(i).Value = "VCH" Then
Range(ROLE).Cells(i).Value = "C-VCH"
Range(FOLLOWUP).Cells(i).ClearContents
Range(REVPROFILE).Value = "N/A"
End If
End If
Next
End Sub
I would go with David Zemens answer but you could also use Range().Find to get the correct columns.
Here I refactored you code to find and set references to your column headers. Everything is based relative to these references.
Here I set a reference to Row 3 of the Survey column where your column header is:
Set rSurvey = .Rows(3).Find(What:="Survey", MatchCase:=False, Lookat:=xlWhole)
Because everything is relative to rSurvey the last row is = the actual last row - rSurvey's row
lastrow = rSurvey(.Rows.Count - rSurvey.Row).End(xlUp).Row - rSurvey.Row
Since rSurvey is a range we know that rSurvey.Cells(1, 1) is our column header. What isn't apparent is that since rSurvey is a range rSurvey(1, 1) is also our column header and since column and row indices are optional rSurvey(1) is also the column header cell.
Know all of that we can iterate over the cells in each column like this
For i = 2 To lastrow
rSurvey( i )
Sub AdjustForNoIntent()
'Adjusts columns Role(U) (to C-MEM), REV Profile Follow-up Date(AJ) (to N/A) and deletes Follow-up Date(Y) when column Survey: Intent to Participate = No
Dim lastrow As Long
Dim i As Long
Dim rRev As Range 'AJ
Dim rRole As Range 'U
Dim rFollowUp As Range 'Y
Dim rSurvey As Range 'AE
With Worksheets("Tracking")
Set rRev = .Rows(3).Find(What:="REV", MatchCase:=False, Lookat:=xlWhole)
Set rRole = .Rows(3).Find(What:="Role", MatchCase:=False, Lookat:=xlWhole)
Set rFollowUp = .Rows(3).Find(What:="Follow-up", MatchCase:=False, Lookat:=xlWhole)
Set rSurvey = .Rows(3).Find(What:="Survey", MatchCase:=False, Lookat:=xlWhole)
lastrow = rSurvey(.Rows.Count - rSurvey.Row).End(xlUp).Row - rSurvey.Row
End With
For i = 2 To lastrow
If Not IsError(rSurvey(i).value) Then
If rSurvey(i).value = "No" And rRole(i).value = "MEM" Then
rRole(i).value = "C-MEM"
rFollowUp(i).ClearContents
rRev(i).value = "N/A"
ElseIf rSurvey(i).value = "No" And rRole(i).value = "VCH" Then
rRole(i).value = "C-VCH"
rFollowUp(i).ClearContents
rRev(i).value = "N/A"
End If
End If
Next i
End Sub
I have a vba code which specifies particular sheet names to look at for example sheet 2,
But what if, someone forgot to change the sheet name to sheet2, can I add a piece of dynamic code to automatically change the vba code for which ever the sheet name is called? for example the second sheet in from the left.
Code Module 1:
Sub Calculation()
Range("P2:P800").Select
Application.CutCopyMode = False
Selection.ClearContents
Dim dict1 As Object
Dim c1 As Variant, k As Variant
Dim currWS As Worksheet
Dim i As Double, lastRow As Double, tot As Double
Dim number1 As Double, number2 As Double, firstRow As Double
Set dict1 = CreateObject("Scripting.Dictionary")
Set currWS = ThisWorkbook.Sheets("Trade data")
'get last row withh data in Column A
lastRow = currWS.Cells(Rows.Count, "M").End(xlUp).Row
'put unique numbers in Column A in dict1
c1 = Range("M2:V" & lastRow)
For i = 1 To UBound(c1, 1)
If c1(i, 1) <> "" Then
'make combination with first 4 characters
dict1(Left(c1(i, 1), 4) & "," & Left(c1(i, 8), 4) & "," & Left(c1(i,
6), 10) & "," & Left(c1(i, 10), 7)) = 1
End If
Next i
'loop through all the numbers in column A
For Each k In dict1.keys
number1 = Split(k, ",")(0)
number2 = Split(k, ",")(1)
tot = 0
firstRow = 0
For i = 2 To lastRow
If k = Left(currWS.Range("M" & i).Value, 4) & "," &
Left(currWS.Range("T" & i).Value, 4) & "," & currWS.Range("R" &
i).Value & "," & (currWS.Range("O" & i).Value) Then
If firstRow = 0 Then
firstRow = i
End If
tot = tot + currWS.Range("W" & i).Value
End If
Next i
currWS.Range("P" & firstRow) = tot
Next k
Call Consolidate
Call SingleTradeMove
End Sub
Module 2 code:
Sub SingleTradeMove()
Dim wsTD As Worksheet
Set wsTD = Worksheets("Trade data")
Sheets("UnMatching").Range("A2:AK600").ClearContents
With wsTD
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To lastRow
If Left(.Cells(i, "M"), 4) <> Left(.Cells(i, "T"), 4) _
Or .Cells(i, "O") <> .Cells(i, "V") _
Or .Cells(i, "R") <> .Cells(i, "Y") Then
.Cells(i, "J").EntireRow.Copy _
Destination:=Sheets("UnMatching").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next i
End With
End Sub
Building off ian0411's answer since I can not comment yet. You can also change this name to short hand. I always change mine to CN and then an abbreviation or something short enough its not a hassle to type out. In the example the sheet name in excel is BlueMoon. So I used CNBM in VBA. This gives a reference to the sheet, and the sheet name on excel's side can be changed without effecting your code. To change the name, click the sheet you want to name in the properties box. Then below that alter the (Name) option.
Say you have a sheet named "Work data" and you programmed as Sheets("Work data"). To make this dynamic, you can use the name before the parenthese that when you launch your Visual Basic editor.
For example, you have this code:
Sheets("Work data").Select
Now you can change to this:
Sheet1.Select
And this way, no matter how users changed the sheet name, it will always work. BUT please remember, the Sheet1 can be also changed but that can only be done inside Visual Basic editor properties. You can password protected the VBA so no one can accidentally alter it.
I am currently building a tool in order to take extracts from SAP and put them into a financial management tool (or Financial Tool). The tool successfully pulls actual data from a SAP CJ74 report, and normalizes the data.
I have a requirement to put a sumproduct function into a spreadsheet to extract data from a data source into the spreadsheet using names and dates as the product match. One sheet is for CAPEX spend, the other sheet is for OPEX spend. The two sheets are replicas of each other.
I attempted to write some code in order to execute my requirement below, but I am getting application defined or object defined error when executing the code. Could I get some assistance with either a better way of doing this, or correcting the errors below?
NOTE: the sheet where this code is running from is the 'Exporter tool'
Sub SumproductAlternative()
Dim Dim wb1 As Workbook, wb2 As Workbook, wb3 As Workbook
Dim Copyrange As Long, MaxRow As Long
Dim CapexPersonName As Range, CapexActualsDate As Range, CapexActualsCell As Range,
Dim OpexPersonName As Range, OpexActualsDate As Range, OpexActualsCell As Range
Dim OpexActualsDate As Range, CapexActualsDate as Range
Dim CapexPersonLookup As Range, OpexPersonLookup As Range
Set wb1 = Workbooks.Open("Financial Tool.xlsm")
Set wb2 = Workbooks.Open("Finance Extract.xlsm")
Set wb3 = Workbooks.Open("Exporter Tool.xlsm")
wb3.Worksheets("Config Sheet").Activate
Set CapexPersonName = ThisWorkbook.Sheets("Config Sheet").Range("A5:A" & LastRow)
Set CapexActualsDate = ThisWorkbook.Sheets("Config Sheet").Range("5:5" & LastColumn)
Set CapexSumRange = ThisWorkbook.Sheets("Capex Pivot").Range("A4").CurrentRegion
Set CapexPersonLookup = wb2.Sheets("Capex").Range("E2:E1300")
Set CapexActualsCell = wb2.Sheets("Capex").Range("5:5" & LastColumn)
Set OpexPersonName = ThisWorkbook.Sheets("Config Sheet").Range("A5:A" & LastRow)
Set OpexActualsDate = ThisWorkbook.Sheets("Config Sheet").Range("5:5" & LastColumn)
Set OpexSumRange = ThisWorkbook.Sheets("Capex Pivot").Range("A4").CurrentRegion
Set OpexPersonLookup = wb2.Sheets("Opex").Range("E2:E1300")
Set OpexActualsCell = wb2.Sheets("Opex").Range("c3:c" & LastRow)
wb1.Sheets("CAPEX").Select
With wb1.Sheets("Capex")
MaxRow = .Range("H528").CurrentRegion.rows.Count
For Copyrange = MaxRow To 528 Step -1
If .Cells(Copyrange).Interior.ColorIndex = 40 Then
.Cells(Copyrange).Formula = " = SUMPRODUCT((CapexPersonName" = "CapexPersonLookup)*(CapexActualsDate" = "CapexActualsCell),(CapexSumRange)"
End If
Next Copyrange
End With
MaxRow = 0
Copyrange = 0
wb1.Sheets("OPEX").Select
With wb1.Sheets("Opex")
MaxRow = .Range("H528").CurrentRegion.rows.Count
For Copyrange = MaxRow To 528 Step -1
If .Cells(Copyrange).Interior.ColorIndex = 40 Then
.Cells(Copyrange).Formula = " = SUMPRODUCT((OpexPersonName" = "OpexPersonLookup)*(OpexActualsDate" = "OpexActualsCell),(OpexSumRange)"
End If
Next Copyrange
End With
This bit concerns me:
Range("5:5" & LastColumn)
If you have say 4 for example as your last column, That range will be Rows 5 - 54 ALL COLUMNS because you are asking for "5:5" & 4 as a string that is "5:54", is this what you are expecting?
Also, where are LastRow and LastColumn being defined?
You assign formula in VBA in a form of string. So this code for example:
.Cells(Copyrange).Formula = "=SUMPRODUCT((CapexPersonName" = "CapexPersonLookup)*(CapexActualsDate" = "CapexActualsCell),(CapexSumRange)"
will error out since it is like a multiple Boolean expression (e.g. x = y = z) which is also not accepted in VBA.
To do what you want, try this:
Dim myformula As String
myformula = "=SUMPRODUCT((" & CapexPersonName.Address(, , , True) & "=" & _
CapexPersonLookup.Address(, , , True) & ")*(" & _
CapexActualsDate.Address(, , , True) & "=" & _
CapexActualsCell.Address(, , , True) & _
")," & CapexSumRange.Address(, , , True) & ")"
.Cells(Copyrange).Formula = myformula