VBA Macro For Naming Ranges - vba

I am trying to use the below to run through values in Column A on a Sheet Named "Report" and Create these ranges in a Sheet called "Holidays_Requested" but everytime I it pops up with
Object Required Runtime error 424.
Can anyone help or know of an alternative way of creating named ranges using VBA.
Sub TransposeRange_new_code()
Dim OutRange As Range
Dim x As Long, y As Long
Dim sKey As String
Dim maxCount As Long
Dim data, dic, keys, items, dataout()
Application.ScreenUpdating = False
data = Sheets("Report").Range("A2:E" & Report.Cells(Report.Rows.Count, "A").End(xlUp).Row).Value2
Set dic = CreateObject("scripting.dictionary")
Set OutRange = Sheets("Holidays_Requested").Range("B2")
For x = 1 To UBound(data, 1)
If Trim$(data(x, 1)) <> "_" Then
sKey = Trim$(data(x, 1)) & Chr(0) & Trim$(data(x, 2))
If Not dic.exists(sKey) Then dic.Add sKey, CreateObject("Scripting.Dictionary")
dic(sKey).Add x, Array(data(x, 4), data(x, 5))
If dic(sKey).Count > maxCount Then maxCount = dic(sKey).Count
End If
Next
ReDim dataout(1 To maxCount + 1, 1 To dic.Count * 3)
keys = dic.keys
items = dic.items
For x = LBound(keys) To UBound(keys)
dataout(1, x * 3 + 1) = Split(keys(x), Chr(0))(0)
dataout(1, x * 3 + 2) = Split(keys(x), Chr(0))(1)
For y = 1 To items(x).Count
dataout(1 + y, x * 3 + 1) = items(x).items()(y - 1)(0)
dataout(1 + y, x * 3 + 2) = items(x).items()(y - 1)(1)
Next y
Next
OutRange.Resize(UBound(dataout, 1), UBound(dataout, 2)).Value2 = dataout
For x = 1 To UBound(keys)
OutRange.Offset(0, (x - 1) * 3).Resize(maxCount, 2).Name = "" & validName(Split(keys(x - 1), Chr(0))(0))
With OutRange.Offset(0, (x - 1) * 3 + 1)
.Hyperlinks.Add anchor:=.Cells(1), Address:="mailto://" & .Value2, TextToDisplay:=.Value2
End With
Next
End Sub

In your code, you're referring to a non-instantiated variable Report. Since this variable hasn't been declared with a Dim statement, it will be treated as an empty variant, zero-length string, or 0-value numeric, or a Nothing object, depending on how/when you call upon it.
And since you're doing Report.__something__ the compiler assumes it's supposed to be an Object (since only Object type have properties/methods). Since it doesn't exist and/or hasn't been assigned, you're doing essentially: Nothing.Cells...
This will always raise a 424 because in order to invoke any .__something__ call, you need to invoke it against a valid, existing Object.
Change:
data = Sheets("Report").Range("A2:E" & Report.Cells(Report.Rows.Count, "A").End(xlUp).Row).Value2
To:
With Sheets("Report")
data = .Range("A2:E" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value2
End With
As always, using Option Explicit in each module will prevent you from executing/running code with undeclared variables. I would recommend adding that statement at the top of each code module, and then rectifying any compile errors (such as Variable undefined) which might arise.
Also: See here for more reliable ways of finding the "last" cell in a given range.
And here is a VB.NET (similar conceptually) explanation of why you should be using Option Explicit.

Related

Manipulating Collections and Arrays in Excel VBA to accommodate missing values and error handling

I did not know how to explain the question so I will attach images for explaining my situation. Here is the view of my Excel Sheet:
My Excel Sheet
The highlighted cells contain multiple values called ID's and are associated with respective Versions in the columns beside them. I use the following macro (details with great explanation here) to split these values into multiple rows in the same sheet.
Option Explicit
Private Const ID_IDX As Long = 0
Private Const VER_IDX As Long = 1
Private Const RNG_IDX As Long = 2
Private Sub RunMe()
Dim data As Variant, cols As Variant, items As Variant
Dim r As Long, c As Long, i As Long, n As Long
Dim ids() As String, vers() As String
Dim addItems As Collection, concatItems As Collection
Dim dataRng As Range, rng As Range
Dim writeID() As Variant, writeVer() As Variant, writeConcat() As Variant
Dim dataStartRow As Long
On Error Resume Next
'Define the range we're interested in and read into an array.
With Sheet1 'adjust for your worksheet object
Set dataRng = Application.InputBox(prompt:="Select the Range of cells:", Type:=8)
End With
data = dataRng.Value2
dataStartRow = 2
'Find the two target columns
cols = AcquireIdAndVerCol(data, 3, 8)
If IsEmpty(cols) Then
MsgBox "Unable to find Id and Ver columns."
Exit Sub
End If
With dataRng
'Add a column next to the version number column.
.Columns(cols(VER_IDX)).Offset(, 1).Insert Shift:=xlShiftToRight, CopyOrigin:=xlFormatFromLeftOrAbove
'Add a column to our range.
'This is to cover the case that the rightmost column is the version number column.
Set dataRng = .Resize(, .Columns.Count + 1)
End With
'Find the rows that need to be split and concatenate the target strings.
Set addItems = New Collection
Set concatItems = New Collection
For r = dataStartRow To UBound(data, 1)
ids = Split(data(r, cols(ID_IDX)), vbLf)
vers = Split(data(r, cols(VER_IDX)), vbLf)
n = IIf(UBound(ids) >= UBound(vers), UBound(ids), UBound(vers))
If n = 0 Then 'it's just one line of text.
'Add concatenated text to list.
concatItems.Add data(r, cols(ID_IDX)) & " " & data(r, cols(VER_IDX))
ElseIf n > 0 Then 'it's multiple lines of text.
'Transpose the id array.
ReDim writeID(1 To UBound(ids) + 1, 1 To 1)
For i = 0 To UBound(ids)
writeID(i + 1, 1) = ids(i)
Next
'Transpose the version array.
ReDim writeVer(1 To UBound(vers) + 1, 1 To 1)
For i = 0 To UBound(ids)
writeVer(i + 1, 1) = vers(i)
Next
'Add concatenated text to list.
For i = 0 To n
concatItems.Add (IIf(UBound(ids) <= n And UBound(vers) <= n, ids(i) & " " & vers(i), Empty))
Next
'Add the range to be split to the collection.
addItems.Add Array(writeID, writeVer, dataRng.Rows(r + 1).Resize(n))
Else 'it's an empty cell
'Add empty item to concatenated list in order to keep alignment.
concatItems.Add Empty
End If
Next
Application.ScreenUpdating = False
'Split the ranges in the list.
If addItems.Count > 0 Then
For Each items In addItems
'Add the rows.
With items(RNG_IDX)
.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Set rng = .Offset(-.Rows.Count - 1).Resize(.Rows.Count + 1)
'Note: format your rng Range obect as desired here.
End With
'Write the id and version values.
rng.Columns(cols(ID_IDX)).Value = items(ID_IDX)
rng.Columns(cols(VER_IDX)).Value = items(VER_IDX)
Next
End If
'Write the concatenated values.
If concatItems.Count > 0 Then
ReDim writeConcat(1 To concatItems.Count + dataStartRow - 1, 1 To 1)
'Header to array.
writeConcat(1, 1) = "Concat values"
'Values from the collection to array.
i = dataStartRow
For Each items In concatItems
writeConcat(i, 1) = items
i = i + 1
Next
'Output array to range.
With dataRng.Columns(cols(VER_IDX) + 1)
.Value = writeConcat
.AutoFit
End With
End If
Application.ScreenUpdating = True
End Sub
Private Function AcquireIdAndVerCol(data As Variant, minCol As Long, maxCol As Long) As Variant
Dim result(1) As Long
Dim r As Long, c As Long, i As Long
Dim items() As String
'Check we're not operating outside bounds of data array.
If minCol < LBound(data, 2) Then minCol = LBound(data, 2)
If minCol > UBound(data, 2) Then minCol = UBound(data, 2)
If maxCol < LBound(data, 2) Then maxCol = LBound(data, 2)
If maxCol > UBound(data, 2) Then maxCol = UBound(data, 2)
'Loop through data to find the two columns.
'Once found, leave the function.
For r = 1 To UBound(data, 1)
For c = minCol To maxCol
items = Split(data(r, c), vbLf)
For i = 0 To UBound(items)
If result(ID_IDX) = 0 Then
If IsDocId(items(i)) Then
result(ID_IDX) = c
If result(VER_IDX) = 0 Then
Exit For
Else
AcquireIdAndVerCol = result
Exit Function
End If
End If
End If
If result(VER_IDX) = 0 Then
If IsDocVer(items(i)) Then
result(VER_IDX) = c
If result(ID_IDX) = 0 Then
Exit For
Else
AcquireIdAndVerCol = result
Exit Function
End If
End If
End If
Next
Next
Next
End Function
Private Function IsDocId(val As String) As Boolean
Dim n As Long
n = TryClng(val)
IsDocId = (n > 9999 And n <= 999999999)
End Function
Private Function IsDocVer(val As String) As Boolean
Dim n As Long, m As Long
Dim items() As String
items = Split(val, ".")
If UBound(items) <> 1 Then Exit Function
n = TryClng(items(0))
m = TryClng(items(1))
IsDocVer = (n > 0 And n <= 99) And (m >= 0 And m <= 9)
End Function
'-------------------------------------------------------------------
'Converts a variant to a Long or returns a fail value as a Long
'if the conversion failed.
'-------------------------------------------------------------------
Private Function TryClng(expr As Variant, Optional fail As Long = -1) As Long
Dim n As Long
n = fail
On Error Resume Next
n = CLng(expr)
On Error GoTo 0
TryClng = n
End Function
It gives the following output with an addition column named, Concat Values, which contains combined values of Id's and corresponding Versions:
Output
Problem:
It works flawlessly if all the ID's have corresponding Versions specified in the sheet separately as I mentioned above. However in cases, where there is only one Version number, and it's bound to 4 or more Id's, i.e. Same Version number is applicable for all the ID's, like such:
The output in the column Concat Values gets disoriented because we are using an array to output the Concat Values and the array is not accommodating the missing Versions for corresponding Id's. It looks like this:
Dislocated row values
I am trying to learn and figure out a way to update the collection and the array with new Concat Values before Outputting it to the column, so that each Concat Value gets placed in their corresponding ID and Version location. I hope that it makes sense. Please let me know for more clarification.
EDIT:
I will try and list all the possible Cases and Expected Output, including the worst case scenarios:
Here is the link to my excel sheet.
Usual Scenarios
Number of Id's = Number of Versions (Works perfectly, Concat Values get aligned in corresponding rows in the columns)
Multiple Id's - Single Version (In such cases, the Version # applicable to all the ID's is same i.e. one Version should be applied to all the ID's.)
Issue:
The Macro does the task of splitting the columns into rows, except the part where Concat values get misaligned.
Worst Case Scenarios
Multiple Id's - Multiple Versions, but less than total #ID's (In such cases, Versions should align to the topmost ID's and fill the ID's below with blanks)
Issue:
The Macro does the task of splitting the columns into rows, except the part where Concat values get misaligned.
Here 4 ID's have been given only 3 Versions, so Top 3 ID's are assigned 3 Versions and the 4th ID has no Version linked to it.
Similarly,
Here 4 ID's have been given only 2 Versions, so Top 2 ID's are assigned 2 Versions and the 3rd and 4th ID's have no Version linked to them.
Multiple Id's - No Version (In such cases, columns should split into rows based on #ID's and corresponding Version rows should be filled with blanks)
Issue:
The Macro does the task of splitting the columns into rows, except the part where Concat values get misaligned.
The complexity of the solution will depend on the complexity and variety of 'special cases'. Given your scenarios, it seems as if you could just take the last of the given versions and, for any versions missing below that line, just use that last used version.
When I gave my first answer, I anticipated this kind of issue, so changes to the code are trivial.
Firstly add an additional declaration in the RunMe Sub:
Dim curVer As String
and then you just need to adjust the ElseIf n > 0 case. Replace the code with this:
ElseIf n > 0 Then 'it's multiple lines of text.
'Resize the output arrays to max ('n')
ReDim writeID(1 To n + 1, 1 To 1)
ReDim writeVer(1 To n + 1, 1 To 1)
'Loop through the arrays to align id and versions.
For i = 0 To n
If i <= UBound(ids) Then
writeID(i + 1, 1) = ids(i)
End If
If i <= UBound(vers) Then
curVer = vers(i)
End If
writeVer(i + 1, 1) = curVer
Next
'Add concatenated text to list.
For i = 0 To n
concatItems.Add writeID(i + 1, 1) & " " & writeVer(i + 1, 1)
Next
'Add the range to be split to the collection.
addItems.Add Array(writeID, writeVer, dataRng.Rows(r + 1).Resize(n))
Too much code for me to read but I came up with my solution if I understood you problem correctly.
I guess it could be a good solution if you modify it. With my code it will be easier to produce a new table instead of adding rows I guess. Then you could just add the formatting which should be very easy.
Sub Test()
Dim xRange As Range
Dim xArrRange() As Variant
Dim xNewArrRange() As Variant
Dim xNewArrRangeResize() As Variant
Dim xNumberColumns As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim l As Long
Dim ii As Long
Dim jj As Long
Set xRange = Range("A2:C5")
xNumberColumns = 3
xArrRange = xRange.Value2
ReDim xNewArrRange(xRange.Rows.Count + 10, xNumberColumns) ' "xNumberColumns - 1" to have the number of columns
' "xNumberColumns" is one more
For i = LBound(xArrRange, 1) To UBound(xArrRange, 1)
Dim xTempArrVer As Variant
Dim xTempArrID As Variant
xTempArrVer = Split(xArrRange(i, 3), vbLf)
If UBound(xTempArrVer) = -1 Then ' If there are no version, initialize it with ""
ReDim xTempArrVer(0)
xTempArrVer(0) = ""
End If
xTempArrID = Split(xArrRange(i, 2), vbLf)
For j = LBound(xTempArrID, 1) To UBound(xTempArrID, 1)
If j > UBound(xTempArrVer, 1) Then
l = UBound(xTempArrVer, 1)
Else
l = j
End If
xNewArrRange(k, 0) = xArrRange(i, 1)
xNewArrRange(k, 1) = xTempArrID(j)
xNewArrRange(k, 2) = xTempArrVer(l)
If xTempArrVer(l) <> "" Then
xNewArrRange(k, 3) = xTempArrID(j) & " " & xTempArrVer(l)
Else
xNewArrRange(k, 3) = xTempArrID(j)
End If
k = k + 1
If k + 1 > UBound(xNewArrRange, 1) Then
ReDim Preserve xNewArrRange(UBound(xNewArrRange, 1) + 30, xNumberColumns)
End If
Next j
Next i
ReDim xNewArrRangeResize(k - 1, xNumberColumns) ' "xNumberColumns - 1" to have the number of columns
' "xNumberColumns" is one more
For ii = LBound(xNewArrRangeResize, 1) To UBound(xNewArrRangeResize, 1)
For jj = LBound(xNewArrRangeResize, 2) To UBound(xNewArrRangeResize, 2)
xNewArrRangeResize(ii, jj) = xNewArrRange(ii, jj)
Next jj
Next ii
Range(Cells(2, 6), Cells(UBound(xNewArrRangeResize, 1) + 1, 6 + UBound(xNewArrRangeResize, 2))).Value2 = xNewArrRangeResize
Debug.Print "Finish"
End Sub
This code produces this:
If your code produces good number of rows for each id etc, the most lazy solution would be just to populate columns of your table with part of my array which is produced at the end.
Edit:
I see there is something missing but that is because I calculated wrongly that Range.
Range(Cells(2, 6), Cells(UBound(xNewArrRangeResize, 1) + 1, 6 + UBound(xNewArrRangeResize, 2))).Value2 = xNewArrRangeResize

Looping through two arrays to check if values match, if not change value

Question updated to make it clear what I am asking and updated the code based on help from the comments.
I have two tables, each with a persons ID, Name, Team and Manager.
Table 1 has the data held previously and Table 2 has the live data which will be updating daily.
I have now created the arrays which loop successfully storing the data from both tables and changes the values in the VBA watch window to match. The issue is during the output I get type data mismatch.
Here is the code I have so far:
Function UpdateReports(rName, srcSheet)
Dim Counter As Long
Dim rr As Long
Dim zz As Long
Dim x As Long
Dim aPID() As String
Dim aName() As String
Dim aTeam() As String
Dim aOps() As String
Dim aRole() As String
Application.ScreenUpdating = False
rPath = "%systemdrive%\users\%username%\Desktop\"
Creator = rPath & "Test Workbook.xlsm"
RepDest = rPath & rName & ".xlsx"
Set sWbk = Nothing
Set sWbk = Workbooks.Open(RepDest, True, True)
'Store tList into Array
Workbooks(Creator).Worksheets("tList").Visible = True
Workbooks(Creator).Worksheets("tList").Activate
Range("A1").CurrentRegion.Select
zz = Selection.Rows.Count - 1
rr = 1
x = 0
Do Until rr > zz ' repeat until end of Staff
rr = rr + 1
x = x + 1
ReDim Preserve aID(1 To x) As String
ReDim Preserve aName(1 To x) As String
ReDim Preserve aTeam(1 To x) As String
ReDim Preserve aManager(1 To x) As String
aID(x) = Int(Cells(rr, 1).Value) ' Store ID
aName(x) = Cells(rr, 2).Value ' Store Name
aTeam(x) = Cells(rr, 3).Value ' Store Team
aManager(x) = Cells(rr, 6).Value ' Store Manager
Loop
'Compare tList to data sheet in report
Workbooks(RepDest).Worksheets(srcSheet).Activate
Range("A1").CurrentRegion.Select
XY = Selection.Rows.Count
For y = 3 To XY
bID = Cells(y, 1).Value
bName = Cells(y, 2).Value
bTeam = Cells(y, 3).Value
bManager = Cells(y, 4).Value
For Z = 1 To zz
If bID = aID(Z) Then
bName = aName(Z)
bTeam = aTeam(Z)
bManager = aManager(Z)
End If
Next z
Next y
' Dim vArray As Variant
' ReDim vArray(LR)
' For x = 8 To LR
' vArray(x) = Cells(x, 3).Value
' Next x
' Worksheets("Breaks Overuse").Activate
' Range("B2").CurrentRegion.Select
' XY = Selection.Rows.Count
' For y = 2 To XY
' PID = Cells(y, 2).Value
' For Z = 8 To LR
' If ID = vArray(Z) Then
' Rows(y).Delete
' y = y - 1
' XY = XY - 1
' End If
' Next Z
' Next y
Sheets(srcSheet).Select
Counter = 0
yy = 1
With Sheets(srcSheet).Range("A1")
For Counter = 1 To x
.Offset([yy], [0]).Value = Format(bID(Counter), "0") 'This is where I get type mismatch, the value for bID is <type mismatch> but in the part above this the value is the ID number 123456
.Offset([yy], [1]).Value = Format(bName(Counter), "#")
.Offset([yy], [2]).Value = Format(bTeam(Counter), "#")
.Offset([yy], [3]).Value = Format(bManager(Counter), "#")
yy = yy + 1
Next
End With
Set sWbk = Nothing
End Function
You are trying to assign a value to a property Creator that is read-only. (It also carries an implicit reference to the Application object, I believe. So you're actually using Application.Creator.)
I'm not sure what your intention in using this property is. Have you checked its value? According to the documentation, it is a constant value. As far as I understand it, when the document was created in a Mac environment, the value might be different. In any case, it doesn't seem very useful for me to name a workbook after it.
As far as building a new workbook name goes, you should really use a new variable for that. Application/document properties (even if writable) are not the place to store runtime information of your script.
As #QHarr already mentioned in the comments, you will never want to ReDim your array within a loop (unless you can help it, but be aware: this smells...).
In your case, it is definitely not necessary to do so:
zz = Selection.Rows.Count - 1
rr = 1
x = 0
Do Until rr > zz ' repeat until end of Staff
rr = rr + 1
x = x + 1
ReDim Preserve aID(1 To x) As String
ReDim Preserve aName(1 To x) As String
ReDim Preserve aTeam(1 To x) As String
ReDim Preserve aManager(1 To x) As String
' assignments removed for brevity
Loop
When the loop starts, the exit condition is already known (you probably should also rewrite this loop as a For ... Next loop). The value zz is known and constant during the loop. The starting value for rr is known, as is the increment. So from the start you know what the value of rr will be at the end. In consequence you also know what x will be at the end and thus what your final size for the arrays needs to be.
The loop runs from rr = 2 (as it starts with r = 1 and then immediately increments it by 1) to rr = zz (as it stops for rr > zz) with Step 1. As x is incremented at the same time, with the same increment, but starts at 0 instead of 1, the final value for x will be x = zz - 1. With that knowledge we can then refactor to:
zz = Selection.Rows.Count - 1
' First dimension arrays outside of the loop
Dim xMax as Long
xMax = zz - 1
ReDim Preserve aID(1 To xMax) As String
ReDim Preserve aName(1 To xMax) As String
ReDim Preserve aTeam(1 To xMax) As String
ReDim Preserve aManager(1 To xMax) As String
' Proceed with filling the arrays in a For ... Next loop
' the index x has been replaced by rr-1
For rr = 2 to zz
aID(rr-1) = Int(Cells(rr, 1).Value) ' Store ID
aName(rr-1) = Cells(rr, 2).Value ' Store Name
aTeam(rr-1) = Cells(rr, 3).Value ' Store Team
aManager(rr-1) = Cells(rr, 6).Value ' Store Manager
Next rr
Regarding your type mismatch error: I can't tell why it happens as you haven't shown us the declarations for all your b variables. And your usage of those variables is inconsistent. At first you seem to be using them as scalars in bID = Cells(y, 1).Value and If bID = aID(Z) Then, but later on you do Format(bID(Counter), "0"), where it's used as an array. You are not only confusing others with this, but also your future self, when you have to look at these lines in a month's time.
Generally: Did you put Option Explicit somewhere at the top of your code module? If not, please do so, asap. I have a feeling this might solve most of your problems. (And if it's not there, please go to the VBE options and enable Require variable declaration on the first page. This will automatically write Option Explicit in every module you create from then on.)

Creating Dictionary Key and Item When Cell Contains Specific Value Only

I am trying to create a dictionary which only adds a key and item when "ABC" is found in Column N. They key is a unique ID (Concatenated attributes) and the item is a number. If the key already exists in the dictionary I want to sum the existing item with the new item (which have the same key / unique ID).
Dim x, x2, y, y2()
Dim i As Long
Dim dict As Object
Dim LastRowForDict As Long
Dim p As Long
dim ws as worksheet
dim LastRowResult as long
set ws = worksheets("DictionaryTest")
Set dict = CreateObject("Scripting.Dictionary")
With ws
LastRowForDict = .Range("B" & rows.Count).End(xlUp).Row
For p = 1 To LastRowForDict
If ws.Range("N" & p).Value = "ABC" Then 'only adds to dictionary if line is an "ABC" line
x = .Range("H2:H" & LastRowForDict).Value
x2 = .Range("AG2:AG" & LastRowForDict).Value
'Check if key exists and if yes add new value to existing item (SUM them)
''' For i = 1 To UBound(x, 1) should this be here?
If Not dict.Exists(x(p, 1)) Then
dict.Item(x(p, 1)) = x2(p, 1)
Else
dict.Item(x(p, 1)) = CDbl(dict.Item(x(p, 1))) + CDbl(x2(p, 1))
End If
'''next i should this be here?
End If
Next p
End With
'map the values
With ws
LastRowResult = .Range("B" & rows.Count).End(xlUp).Row
y = .Range("H2:H" & LastRowResult).Value 'looks up to this range
ReDim y2(1 To UBound(y, 1), 1 To 1) '<< size the output array
For i = 1 To UBound(y, 1)
If dict.Exists(y(i, 1)) Then
y2(i, 1) = dict(y(i, 1))
Else
y2(i, 1) = ""
End If
Next i
.Range("CK2:CK" & LastRowResult).Value = y2 '<< place the output on the sheet
End With
I currently am getting an error (RunTime 9 - Subscript Out Of Range) on this line If Not dict.Exists(x(p, 1)) Then and this error occurs on the last row of data on my worksheet (ie. It occurs on LastRowForDict). I am thinking this is related to the UBound that I have commented out? I removed it because it causes the code to run from row 1 to UBound / LastRowForDict every time the "outer" if statement is met. By this I mean for every "ABC" line, the code runs through all rows on the sheet and thus creates incorrect items.
Thank you in advance for any help you can offer!

Referencing worksheets to draw data

I am writing a vba macro to allow me to reference data from a worksheet and summarize some of the data rather than using a ton of formulas to do so.
I am having difficulties in referencing worksheets and have reverted to activating sheets. I'm not sure what I am doing incorrectly. For example:
Sheets("Rainfall").Activate
Set x = Range(Range("C2"), Range("C2").End(xlDown))
rather than
Set x = Sheets("Rainfall").Range(Range("C2"), Range("C2").End(xlDown))
When I attempt to reference code such as
Cells(2 + j, 3) = Application.WorksheetFunction.VLookup(Cells(2 + j, 2), Worksheets("Raw Data").Range(Range("C4"), Range("H4").End(xlDown)), 6, False)
I get a 1004 error. Below is my code and if anyone has any suggestions on the simplification of the code that would be great as well.
Sub selectall()
Dim x, y As Range
Dim nv, rd As Long
Set Wkb = Workbooks("DWH Calculations V1.xlsm")
Sheets("Rainfall").Activate
Set x = Range(Range("C2"), Range("C2").End(xlDown))
nv = x.Rows.Count
'MsgBox (nv)
Sheets("Raw Data").Activate
Set y = Range(Range("E4"), Range("E4").End(xlDown))
rd = y.Rows.Count
'MsgBox (rd)
MinD = Round(Application.WorksheetFunction.Min(y), 0)
MaxD = Round(Application.WorksheetFunction.Max(y), 0)
Ndays = MaxD - MinD
'MsgBox (Ndays)
Sheets("Rainfall").Activate
Cells(2, 2) = MinD
For j = 1 To Ndays - 1
Cells(2 + j, 2) = Cells(1 + j, 2) + 1
Cells(2 + j, 3) = Application.WorksheetFunction.VLookup(Cells(2 + j, 2), Worksheets("Raw Data").Range(Range("C4"), Range("H4").End(xlDown)), 6, False)
Next j
End Sub
Thank you all for your help
This has been asked many times before - you need to qualify all the Range calls with a worksheet object, so:
Set x = Sheets("Rainfall").Range(Sheets("Rainfall").Range("C2"), Sheets("Rainfall").Range("C2").End(xlDown))
or use a With...End With block:
With Sheets("Rainfall")
Set x = .Range(.Range("C2"), .Range("C2").End(xlDown))
End With
and note the periods before all three Range calls. You can also use a Worksheet variable:
Dim ws as Worksheet
Set ws = Sheets("Rainfall")
Set x = ws.Range(ws.Range("C2"), ws.Range("C2").End(xlDown))
The problem is the range-within-range:
replace:
Set x = Range(Range("C2"), Range("C2").End(xlDown))
with:
With Sheets("Rainfall")
Set x = .Range(.Range("C2"), .Range("C2").End(xlDown))
End With
Activate is not needed to Set ranges.

VBA Excel Finding and Combining Rows Based on Matching Column Cells

I'm trying to figure out a way to combine rows based on values in two specific columns in vba excel.
For Example:
Let's say I have the following sheet:
Column A Column J Column Z
1 A ?
1 A !
2 B ?
2 B !
And I need to convert it to this:
Column A Column J Column Z
1 A ?, !
2 B ?, !
Here's another method using User Defined Types and collections to iterate through the list and develop the combined results. For large sets of data, it should be considerably faster than reading through each cell on the worksheet.
I assume that you are grouping on Col J, and that Column A data does not need to be concatenated in the cell. If it does, the modifications to the routine would be trivial.
First, Insert a Class Module, rename it CombData and insert the following code into that module:
Option Explicit
Private pColA As String
Private pColJ As String
Private pColZConcat As String
Public Property Get ColA() As String
ColA = pColA
End Property
Public Property Let ColA(Value As String)
pColA = Value
End Property
Public Property Get ColJ() As String
ColJ = pColJ
End Property
Public Property Let ColJ(Value As String)
pColJ = Value
End Property
Public Property Get ColZConcat() As String
ColZConcat = pColZConcat
End Property
Public Property Let ColZConcat(Value As String)
pColZConcat = Value
End Property
Then Insert a Regular Module and insert the Code Below:
Option Explicit
Sub CombineData()
Dim cCombData As CombData
Dim colCombData As Collection
Dim V As Variant
Dim vRes() As Variant 'Results Array
Dim rRes As Range 'Location of results
Dim I As Long
'read source data into array
V = Range("A1", Cells(Rows.Count, "A").End(xlUp)).Resize(columnsize:=26)
'Set results range. Here it is set below the Source Data
'Could be anyplace, even on a different worksheet; or could overlay the
' original. Area below and to right is cleared
Set rRes = Range("A1").Offset(UBound(V) + 10)
Range(rRes, rRes.SpecialCells(xlCellTypeLastCell)).Clear
Set colCombData = New Collection
On Error Resume Next
For I = 1 To UBound(V)
Set cCombData = New CombData
cCombData.ColA = V(I, 1)
cCombData.ColJ = V(I, 10)
cCombData.ColZConcat = V(I, 26)
colCombData.Add cCombData, CStr(cCombData.ColJ)
If Err.Number <> 0 Then
Err.Clear
With colCombData(cCombData.ColJ)
.ColZConcat = .ColZConcat & ", " & V(I, 26)
End With
End If
Next I
On Error GoTo 0
ReDim vRes(1 To colCombData.Count, 1 To 26)
For I = 1 To UBound(vRes)
With colCombData(I)
vRes(I, 1) = .ColA
vRes(I, 10) = .ColJ
vRes(I, 26) = .ColZConcat
End With
Next I
rRes.Resize(UBound(vRes, 1), UBound(vRes, 2)) = vRes
End Sub
EDIT: Note that the source data is read into the Variant array V. If you examine V in the Watch Window, you will see that the first dimension represents the rows; and the second dimension the columns. So if you wanted, for example, to perform the same procedure on a different set of columns, you would merely change the references to the second dimension under the line that reads Set cCombData = New CombData. For example, column B data would be V(I,2), and so forth. Of course, you might want to rename the data types to make them more representative of what you are doing.
In addition, if your data starts at row 2, merely start the iteration through V with I = 2 instead of I = 1.
EDIT2: In order to both overwrite the original, and also maintain the contents of the columns not being processed, the following modification will do that for Columns A, J and Z. You should be able to modify it for whatever columns you choose to process.
Option Explicit
Sub CombineData()
Dim cCombData As CombData
Dim colCombData As Collection
Dim V As Variant
Dim vRes() As Variant 'Results Array
Dim rRes As Range 'Location of results
Dim I As Long, J As Long, K As Long
'read source data into array
V = Range("A1", Cells(Rows.Count, "A").End(xlUp)).Resize(columnsize:=26)
'Set results range. Here it is set below the Source Data
'Could be anyplace, even on a different worksheet; or could overlay the
' original. Area below and to right is cleared
Set rRes = Range("A1") '.Offset(UBound(V) + 10)
Range(rRes, rRes.SpecialCells(xlCellTypeLastCell)).Clear
Set colCombData = New Collection
On Error Resume Next
For I = 1 To UBound(V)
Set cCombData = New CombData
cCombData.ColA = V(I, 1)
cCombData.ColJ = V(I, 10)
cCombData.ColZConcat = V(I, 26)
colCombData.Add cCombData, CStr(cCombData.ColJ)
If Err.Number <> 0 Then
Err.Clear
With colCombData(cCombData.ColJ)
.ColZConcat = .ColZConcat & ", " & V(I, 26)
End With
End If
Next I
On Error GoTo 0
ReDim vRes(1 To colCombData.Count, 1 To 26)
For I = 1 To UBound(vRes)
With colCombData(I)
vRes(I, 1) = .ColA
vRes(I, 10) = .ColJ
vRes(I, 26) = .ColZConcat
'Note the 10 below is the column we are summarizing by
J = WorksheetFunction.Match(.ColJ, WorksheetFunction.Index(V, 0, 10), 0)
For K = 1 To 26
Select Case K 'Decide which columns to copy over
Case 2 To 9, 11 To 25
vRes(I, K) = V(J, K)
End Select
Next K
End With
Next I
rRes.Resize(UBound(vRes, 1), UBound(vRes, 2)) = vRes
End Sub
This is assuming that Column J is the key and Column A doesn't need to be appended. If Column A needs to be combined as well (not always the same), you would simply need to add another for each loop to check if the data is there, and add it if not, as done for col 26 in the code.
Sub CombineData()
x = 2
Do Until Cells(x, 1) = "" 'loop through every row in sheet starting at 2 (1 will never be removed, since it is the first data)
x2 = 1
Do Until x2 = x
If Cells(x, 10) = Cells(x2, 10) Then 'this is comparing column J. If another column is the reference then change 10 to the column number
splt = Split(Cells(x, 26), ", ")
For Each s In splt 'check to see if data already in column z
If s = Cells(x2, 26) Then GoTo alreadyEntered
Next
Cells(x, 26) = Cells(x, 26) & ", " & Cells(x2, 26) 'append column z data to row x
alreadyEntered:
Rows(x2).Delete Shift:=xlUp 'delete duplicate row
x = x - 1 'to keep x at same row, since we just removed a row
Exit Do
Else
x2 = x2 + 1
End If
Loop
x = x + 1
Loop
End Sub