I have a simple index file which will cycle through 500+ files and will retrieve relevant information. One of the index fields is a VLookUp, which references another sheet in the active index Workbook. While testing the script, the VLookUp function cannot find the appropriate value, even though it will when I manually enter the same formula into a cell. Any ideas why this might be happening (it returns "N/A" every time, as indicated by the ErrorHandling):
Public Sub UpdateIndex()
Dim RowNumber As Integer, LookUpLast As Integer
Dim Control As String, PartNumber As String, PartDescription As String, Rev As String
Dim LookUp As Range, IndexLookup As Variant
Control = "Arbitrary"
RowNumber = 2
With ThisWorkbook.Worksheets(Sheet2)
LookUpLast = .Range("A" & Rows.Count).End(xlUp).Row
Set LookUp = .Range(.Cells(2, 1), .Cells(LookUpLast, 2)) 'Had previously tried Range("A2", "B" & LookUpLast)
End With
IndexLookup = Application.WorksheetFunction.VLookUp(Control, LookUp, 2, False)
With ThisWorkbook.Worksheets(Sheet1)
.Range("D" & RowNumber) = IndexLookup
End With
RowNumber = RowNumber + 1
Next File
Exit Sub
ErrorHandler:
If Err.Number = 1004 Then
IndexLookup = "N/A"
Resume Next
End If
End Sub
Related
I am getting to know Excel VBA. I have a working program that uses an action button on one sheet opens a source workbook and data worksheet, selects data and puts that into a second workbook and destination sheet. I then sort the data as needed and it looks like this
Destination sheet, sorted and annotated duplicates
I am now trying to select the data based on col 2 "B" where the items are duplicated and/or not duplicated then perform an action (send an email to the manager about the staff under their control). I can get an email to work but its selecting the data that I'm having trouble with.
the output data would be col 1 & col 3 to 5 e.g.
Dear Manager1,
you staff member/s listed below have achieved xyz
Person1 22/06/2017 11/08/2017 22/08/2017
Person11 22/06/2017 11/08/2017 22/08/2017
Person15 22/06/2017 11/08/2017 22/08/2017
congratulations....
So what I hope somebody can help me with is a clue how I get to look at the data in col 2
add the Row data required to an array or something then to check the next Row add it to the same something until it is different to the next Row Pause do the action then do the next iteration. Resulting in:
Manager1 .....Person 1,11,15action
Manager10 ..... Person 10action
Manager2 ..... Person 12,16,2,25,28action
Manager3 ..... Person 13,17,26,29,3action
until last line is reached.
I am so confused with arrays / lookups and loops I have lost the plot somewhere along the way.
I have a variable lastTmp which tells me the last line of data in the set, this will vary each month.
The Range is:
Set rng1 = Range("B5:B" & Cells(Rows.Count, "B").End(xlUp).row)
The last piece of my working code is:
Dim lp As Integer
lp = 1
For Each cell In rng1
If 1 < Application.CountIf(rng1, cell.Value) Then
With cell
.Offset(0, 4) = "duplicate : "
.Offset(0, 5) = lp
End With
Else
With cell
.Offset(0, 4) = "NOT duplicate : "
.Offset(0, 5) = 0
End With
End If
Next cell
You will be better placed to confront confusion if you do your indenting more logically. Related For / Next, If / Else / End If and With / End With should always be on the same indent level for easier reading. I rearranged your original code like this:-
For Each Cell In Rng1
If 1 < Application.CountIf(Rng1, Cell.Value) Then
With Cell
.Offset(0, 4) = "duplicate : "
.Offset(0, 5) = lp
End With
Else
With Cell
.Offset(0, 4) = "NOT duplicate : "
.Offset(0, 5) = 0
End With
End If
Next Cell
It now becomes apparent that the With Cell / End With need not be duplicated. I have further presumed that your variable lp actually was intended to hold the count. That made me arrive at the following compression of your code.
Dim Rng1 As Range
Dim Cell As Range
Dim lp As Integer
' the sheet isn't specified: uses the ActiveSheet
Set Rng1 = Range("B5:B" & Cells(Rows.Count, "B").End(xlUp).Row)
For Each Cell In Rng1
With Cell
lp = Application.CountIf(Rng1, .Value)
.Offset(0, 4) = IIf(lp, "", "NOT ") & "duplicate : "
.Offset(0, 5) = lp
End With
Next Cell
Consider using a Dictionary or Collection, whenever, checking for duplicates.
Here I use a Dictionary of Dictionaries to compile lists of Persons by Manager.
Sub ListManagerList1()
Dim cell As Range
Dim manager As String, person As String
Dim key As Variant
Dim dictManagers As Object
Set dictManagers = CreateObject("Scripting.Dictionary")
For Each cell In Range("B5:B" & Cells(Rows.Count, "B").End(xlUp).Row)
manager = cell.Value
person = cell.Offset(0, -1).Value
If Not dictManagers.Exists(manager) Then
dictManagers.Add manager, CreateObject("Scripting.Dictionary")
End If
If Not dictManagers(manager).Exists(person) Then
dictManagers(manager).Add person, vbNullString
End If
Next
For Each key In dictManagers
Debug.Print key & " -> "; Join(dictManagers(key).Keys(), ",")
Next
End Sub
I recommend you wanting Excel VBA Introduction Part 39 - Dictionaries
Assuming your data is as in the image
Then following code will give you result as in the image below.
Sub Demo()
Dim srcSht As Worksheet, destSht As Worksheet
Dim lastRow As Long, i As Long
Dim arr1(), arr2()
Dim dict As Object
Set dict = CreateObject("scripting.dictionary")
Set srcSht = ThisWorkbook.Sheets("Sheet2") 'change Sheet2 to your data sheet
Set destSht = ThisWorkbook.Sheets("Sheet1") 'change Sheet1 to your output sheet
arr1 = Application.Index(srcSht.Cells, [row(1:7000)], Array(2, 1)) 'See note below
arr2 = arr1
For i = 1 To UBound(arr1, 1)
If Not dict.exists(LCase$(arr1(i, 1))) Then
dict.Add LCase$(arr1(i, 1)), i
Else
arr2(i, 1) = vbNullString
arr2(dict.Item(LCase$(arr1(i, 1))), 2) = arr2(dict.Item(LCase$(arr1(i, 1))), 2) & "," & arr1(i, 2)
End If
Next
destSht.Range("A1").Resize(UBound(arr1, 1), UBound(arr1, 2)) = arr2 'display result
destSht.Columns("a").SpecialCells(xlBlanks).EntireRow.Delete
End Sub
Note : For details on assigning range to array see this.
I need some help to create a macro which adds all the values on the column E between the rows with the "avg" word. the result should be displayed on the cells where the "Sum here" label is displayed. Both texts "avg" and "sum here" is just for illustrate the example, "avg" could be replaced by any other word and "sum here" should actually be the aggregation of the values above it.
The real challenge is that the number of ranges on column E is variable, so i would like to find a macro which is able to deal with "n" number of ranges on column E.
Finally, the values on column D are only the example of the expected value on the "sum here" cells.
This is what I have tried to far:
Sub Macro1()
'
' Macro1 Macro
'
Dim sumhere As Range
Dim startingpoint As Range
Dim endingpoint As Range
'
Range("C17").Select
Selection.End(xlDown).Select
If ActiveCell = "avg" Then
ActiveCell.Offset(rowoffset:=0, columnoffset:=2).Select
Set sumhere = ActiveCell
Set startingpoint = ActiveCell.Offset(rowoffset:=-1, columnoffset:=0)
Selection.End(xlUp).Select
If (ActiveCell.Value) = "Sum here" Then
Set endingpoint = ActiveCell.Offset(rowoffset:=1, columnoffset:=0)
sumhere.Formula = "=sum(range(startingpoint:endingpoint)"
Else
Selection.End(xlUp).Select
If (ActiveCell.Value) = "Sum here" Then
Set endingpoint = ActiveCell.Offset(rowoffset:=1, columnoffset:=0)
sumhere.Formula = "=Sum(Range(startingpoint.adress:endingpoint.adress))"
Else: End If
End If
End If
End Sub
Additionally, as you can see, I do not know, how to define a range using variables. My original idea was to combine this code with some kind of "do while" or/and "for i= 1 to x" and "next i". But I can't see how to combine it.
Using formula only, and providing that column A only has avg (or any text) on each subtotal row.
I've given two versions of the formula - the volatile version (updates everytime you change anything on the spreadsheet), and the non-volatile version (only updates if it needs to).
The formula should be entered on row 6 - change the $E6 to which ever row you need.
(volatile)
=SUM(OFFSET($E6,IFERROR(LOOKUP(2,1/($A$1:INDEX($A:$A,ROW()-1)<>""),ROW($A$1:INDEX($A:$A,ROW()-1))),0)-ROW()+1,,ROW()-1-IFERROR(LOOKUP(2,1/($A$1:INDEX($A:$A,ROW()-1)<>""),ROW($A$1:INDEX($A:$A,ROW()-1))),0)))
(non volatile):
=SUM(INDEX($E:$E,IFERROR(LOOKUP(2,1/($A$1:INDEX($A:$A,ROW()-1)<>""),ROW($A$1:INDEX($A:$A,ROW()-1))),0)+1):INDEX($E:$E,ROW()-1))
or if you don't mind using a helper column:
In cell B6:
=IFERROR(LOOKUP(2,1/($A$1:INDEX($A:$A,ROW()-1)<>""),ROW($A$1:INDEX($A:$A,ROW()-1))),0)
In E6: (volatile)
=SUM(OFFSET($E6,$B6-ROW()+1,,ROW()-1-$B6))
or (non volatile):
=SUM(INDEX($E:$E,$B6):INDEX($E:$E,ROW()-1))
Edit:
Thought I'd add a UDF to calculate it to if you're after VBA.
Use the function =AddSubTotal() in the rows you want the sub total to be shown in, or use =AddSubTotal("pop",6) to sum everything in column F (col 6) using "pop" rather than "avg".
Public Function AddSubTotal(Optional Delim As String = "avg", Optional ColNumber = 5) As Double
Dim rCaller As Range
Dim rPrevious As Range
Dim rSumRange As Range
Set rCaller = Application.Caller
With rCaller.Parent
Set rPrevious = .Range(.Cells(1, 1), .Cells(rCaller.Row - 1, 1)).Find(Delim, , , , , xlPrevious)
If Not rPrevious Is Nothing Then
Set rSumRange = rPrevious.Offset(1, ColNumber - 1).Resize(rCaller.Row - rPrevious.Row - 1)
Else
Set rSumRange = .Range(.Cells(1, ColNumber), .Cells(rCaller.Row - 1, ColNumber))
End If
End With
AddSubTotal = WorksheetFunction.Sum(rSumRange)
End Function
The following VBA routine assumes that
your data is in Columns C:E
Nothing else relevant (nothing numeric) in that range
Your "key word" where you want to show the sum is avg
avg (the key word) is hard-coded in the macro
You could easily modify this routine to also perform an average of those values, and put those results, for example, in Column D
Any of the above are easily modified
Option Explicit
Sub TotalSubRanges()
Dim vSrc As Variant, rSrc As Range
Dim dAdd As Double
Dim I As Long
Const sKey As String = "avg"
Set rSrc = Range(Cells(1, "C"), Cells(Rows.Count, "C").End(xlUp)).Resize(columnsize:=3)
vSrc = rSrc
'Do the "work" in a VBA array, as this will
' execute much faster than working directly
' on the worksheet
For I = 1 To UBound(vSrc, 1)
If vSrc(I, 1) = sKey Then
vSrc(I, 3) = dAdd
dAdd = 0
Else
If IsNumeric(vSrc(I, 3)) Then dAdd = dAdd + vSrc(I, 3)
End If
Next I
'write the results back to the worksheet
' and conditionally format the "sum" cells
With rSrc
.EntireColumn.Clear
.Value = vSrc
.Columns(3).AutoFit
.EntireColumn.ColumnWidth = .Columns(3).ColumnWidth
.FormatConditions.Delete
.FormatConditions.Add _
Type:=xlExpression, _
Formula1:="=" & .Item(1, 1).Address(False, True) & "=""" & sKey & """"
With .FormatConditions(1)
.Interior.ColorIndex = 6
End With
End With
End Sub
Surely you just need something like:
Sub sums()
Dim i As Integer, j As Integer, k As Integer
j = Range("C1048576").End(xlUp).Row
k = 1
For i = 1 To j
If Range("C" & i).Value <> "" Then
Range("E" & i).Value = "=Sum(E" & k & ":E" & i - 1 & ")"
k = i + 1
End If
Next i
End Sub
Change:
Dim startingpoint As Range
Dim endingpoint As Range
To:
Dim startingpoint As Variant
Dim endingpoint As Variant
As the startingpoint and endingpoint is used in a formula, you cant define them as a Range.
I want to create a index list of all sheets with their names in a table column.
So far I have written the below code but it gives an error on a quoted line.
Dim ws As Worksheet, tbl As ListObject, i As Integer
Set ws = Sheets("Profile Management")
Set tbl = ws.ListObjects("sheets")
With tbl.ListRows
Do While .Count >= 1
.Item(1).Delete
Loop
End With
For i = 1 To Sheets.Count
"tbl.ListColumns(1).DataBodyRange = Sheets(i).Name"
Next I
Where I am going wrong?
The following is much simpler.
Sub GetWorksheetNames()
Dim i As Long
ThisWorkbook.Worksheets("Profile Management").Cells(1, 1).Value = "Worksheet Inventory"
For i = 1 To ThisWorkbook.Worksheets.Count
ThisWorkbook.Worksheets("Profile Management").Cells(i + 1, 1).Value = ThisWorkbook.Worksheets(i).Name
Next i
End Sub
Working with structured (aka ListObject) tables brings some additional concerns to VBA. You cannot write to the .DataBodyRange property that way and the .DataBodyRane is a member of the ListObject, not the ListObject's ListColumns property.
Option Explicit
Sub wqwe()
Dim tbl As ListObject, i As Long, w As Long
With Worksheets("Profile Management")
With .ListObjects("sheets")
'make sure there is at least 1 row in the databodyrange
If .DataBodyRange Is Nothing Then _
.ListRows.Add
'clear the first column
.DataBodyRange.Columns(1).ClearContents
'insert the worksheet names
For w = 1 To Worksheets.Count
'except "Profile Management"
If Worksheets(w).Name <> .Parent.Name Then
i = i + 1
'expand the table for new worksheets
.DataBodyRange.Cells(i, 1) = Worksheets(w).Name
'optionally insert a hyperlink to each worksheet's A1
.Parent.Hyperlinks.Add Anchor:=.DataBodyRange.Cells(i, 1), _
Address:=vbNullString, SubAddress:=Worksheets(w).Name & "!A1", _
TextToDisplay:=Worksheets(w).Name, ScreenTip:="click to go there"
End If
Next w
'reshape the table if there are blank rows
Do While i < .ListRows.Count
.ListRows(i + 1).Delete
Loop
End With
End With
End Sub
As noted in comments above, I've added the option to hyperlink to each worksheet directly from its listing in the table. If you choose this route, you do not have to put the name into the table cell first.
I am in kind of a pickle :(
I have the below data and the task is to identify the unique records and combine them summing the values.
Let me explain, below is the data:
OrgData http://im80.gulfup.com/uDNyW7.png
So the end result that I need to get is the data per visit of each client with total of the price and the item name to be kept as the first item:
EndData http://im75.gulfup.com/PvkIWz.png
I have tried using a helper column which is a combination of the "Client ID" and the "Date"
For i = 1 to Lastrow
Worksheets("Sheet1").Range("F" & i).Value = Worksheets("Sheet1").Range("A" & i).Value & _
Worksheets("Sheet1").Range("C" & i).Value
Next i
I then tried to copy the helper column to a temp sheet and remove duplicates and then for each of the remaining values I used autofilter by the helper column value and then summed the result of column D and wrote that to a new sheet.
Set rng = Sheet1.Range("D2:D" & lastrow2)
total = Application.WorksheetFunction.Sum(rng.SpecialCells(xlCellTypeVisible))
But given that my sheet has more than 60K + rows, it takes forever.
I am sure that there is a better approach out there, but just can't think of any.
Here is a VBA solution using a User Defined Object: cVisit which has the five properties of ID, Name, Date, Price and Item.
EDIT: I ran some timing tests and, depending on the distribution of duplicates in the source data, it runs in five to fifteen seconds on my machine with a data source of 60,000 rows.
First insert a class module, rename it cVisit, and paste the following code:
Option Explicit
Private pID As String
Private pName As String
Private pDT As Date
Private pPrice As Double
Private pItem As String
Public Property Get ID() As String
ID = pID
End Property
Public Property Let ID(Value As String)
pID = Value
End Property
Public Property Get Name() As String
Name = pName
End Property
Public Property Let Name(Value As String)
pName = Value
End Property
Public Property Get DT() As Date
DT = pDT
End Property
Public Property Let DT(Value As Date)
pDT = Value
End Property
Public Property Get Price() As Double
Price = pPrice
End Property
Public Property Let Price(Value As Double)
pPrice = Value
End Property
Public Property Get Item() As String
Item = pItem
End Property
Public Property Let Item(Value As String)
pItem = Value
End Property
Then, in a regular module:
Option Explicit
Sub DailyVisits()
Dim wsSrc As Worksheet, vSrc As Variant, rSrc As Range
Dim vRes() As Variant, wsRes As Worksheet, rRes As Range
Dim cV As cVisit, colVisits As Collection
Dim I As Long
Dim sKey As String
Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet1")
Set rRes = wsRes.Range("H1")
'Read source data into an array as it is much faster to iterate through a VBA array
' than a worksheet
With wsSrc
Set rSrc = .Range("a1", .Cells(.Rows.Count, "A").End(xlUp)).Resize(columnsize:=5)
vSrc = rSrc
End With
'Collect all the visits into a Collection keyed to Client ID and Date
Set colVisits = New Collection
On Error Resume Next
For I = 2 To UBound(vSrc, 1)
Set cV = New cVisit
With cV
.ID = vSrc(I, 1)
.Name = vSrc(I, 2)
.DT = vSrc(I, 3)
.Price = vSrc(I, 4)
.Item = vSrc(I, 5)
sKey = CStr(.ID & "|" & .DT)
colVisits.Add cV, sKey
'If the record for this ID and date already exists, then add the
'price to the existing record. Else a new record gets added
If Err.Number = 457 Then
With colVisits(sKey)
.Price = .Price + cV.Price
End With
ElseIf Err.Number <> 0 Then Stop
End If
Err.Clear
End With
Next I
On Error GoTo 0
'To minimize chance of out of memory errors with large database
Erase vSrc
vSrc = rSrc.Rows(1)
'Write the collection to a "results" array
'then write it to the worksheet and format
ReDim vRes(0 To colVisits.Count + 1, 1 To 5)
For I = 1 To UBound(vRes, 2)
vRes(0, I) = vSrc(1, I)
Next I
For I = 1 To colVisits.Count
With colVisits(I)
vRes(I, 1) = .ID
vRes(I, 2) = .Name
vRes(I, 3) = .DT
vRes(I, 4) = .Price
vRes(I, 5) = .Item
End With
Next I
With rRes.Resize(UBound(vRes), UBound(vRes, 2))
.EntireColumn.Clear
.Value = vRes
With .Rows(1)
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
.Columns(3).NumberFormat = "d/mm/yyyy"
.Columns(4).NumberFormat = "$#,##0.00"
.EntireColumn.AutoFit
End With
End Sub
Adjust your source and results worksheet as you like, and the first cell of the results range and Run.
A simple way to do this would be to combine the two cells so in F2 type
=A2 & D2
Then sort column E, then run a subtotal on your data, that sums column D at every change in column F.
OP wants VBA but has also mentioned "what else can I try" so on the excuse that this may allow for other possibilities, a formula basis solution might be to:
Work on a copy.
Add a column (say A, with =IF(OR(B1<>B2,D1<>D2),"*","") in A2 copied down to suit (ie ~60k rows) and add * at the bottom of the list. (Hopefully this will cover the situation where different days are next to one another but with the same client ID, though that is not shown in the example).
Copy A and Paste Special Values over the top (may be possible to skip until part of step 6).
There should now be asterisks to mark the rows from which Item names are to be retained (and where the totals are required).
In G2 and copied down to suit: =IF(ISBLANK(A2),"",SUM(INDIRECT("E"&ROW()&":E"&ROW()+MATCH("~*",A3:A$65000,0)-1)))
Select, Copy and Paste Special, Values over the top.
Filter to select (Blank) in ColumnA and delete all visible except header.
Remove the filter.
Should be a lot quicker that multiple Subtotals, but still may not be suitable if to be repeated frequently. However corresponding steps could be built into a subroutine, or the above recorded for a macro.
I have a worksheet which has many terms in Column A.I want to search for two terms for example
term A and term B and copy all rows between the two terms and paste it into a new sheet.These two terms may repeat in the column. The problem which I am basically facing the following problem : whenever I run my code it also copies rows between term B and term A which is unnecessary. Following is the code i am using for two terms term A and term B.
For example my column A is
Institute
Event
Job
Computer
Laptop
Figures
Event
figures
format
computer
and many more terms
I want to copy all the rows between term A: Event and term B: Laptop and paste it into a new sheet. What my code is doing is it is copying the rows between all combinations of Event and computer. Even the rows between computer and event are copied(in this case Figure and laptop).
Sub OpenHTMLpage_SearchIt()
Dim Cell As Range, Keyword$, N%, SearchAgain As VbMsgBoxResult
Dim ass As Variant
Dim Cellev As Range, prakash$, P%, SearchAgaina As VbMsgBoxResult
Dim asa As Variant
StartSearch:
N = 1
Keyword = "Event"
If Keyword = Empty Then GoTo StartSearch
For Each Cell In Range("A1:A500")
If Cell Like "*" & Keyword & "*" Then
ass = Cell.Address
P = 1
prakash = "Computer"
If prakash = Empty Then GoTo StartSearch
For Each Cellev In Range("A1:A500")
If Cellev Like "*" & prakash & "*" Then
asa = Cellev.Address
Range(asa, ass).Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
Range("B13").Select
ActiveSheet.Paste
Worksheets("sheet1").Select
P = P + 1
End If
Next Cellev
N = N + 1
End If
Next Cell
End Sub
Edit: code formatting.
The following is the code which is working for me.This copies everything in between Event and laptop and pastes it into a new sheet. Then again it searches for a second time and this time the search will start from the next row to the first search.I hope I am clear with this.
Sub Star123()
Dim rownum As Long
Dim colnum As Long
Dim startrow As Long
Dim endrow As Long
Dim lastrow As Long
rownum = 1
colnum = 1
lastrow = Worksheets("Startsheet").Range("A65536").End(xlUp).Row
With ActiveWorkbook.Worksheets("StartSheet").Range("a1:a" & lastrow)
For rownum = 1 To lastrow
Do
If .Cells(rownum, 1).Value = "Event" Then
startrow = rownum
End If
rownum = rownum + 1
If (rownum > lastrow) Then Exit For
Loop Until .Cells(rownum, 1).Value = "Laptop"
endrow = rownum
rownum = rownum + 1
Worksheets("StartSheet").Range(startrow & ":" & endrow).Copy
Sheets("Result").Select
Range("A1").Select
ActiveSheet.Paste
Next rownum
End With
End Sub
Try this:
Sub DoEeeeeet(sheetName, termA, termB)
Dim foundA As Range, _
foundB As Range
Dim newSht As Worksheet
With Sheets(sheetName).Columns(1)
Set foundA = .Find(termA)
If Not foundA Is Nothing Then
Set foundB = .Find(termB, after:=foundA, searchdirection:=xlPrevious)
End If
End With
If foundA Is Nothing Or foundB Is Nothing Then
MsgBox "Couldn't find " & IIf(foundA Is Nothing, termA, termB)
Else
Range(foundA, foundB).Copy
Set newSht = Sheets.Add
newSht.Range("B13").PasteSpecial
End If
End Sub
You can call it as follows:
DoEeeeeet "Sheet1","Event","Laptop"
It'll find the first instance of "Event" and the last instance of "Laptop" on the sheet named "Sheet1" and copy all of that data to B13 and subsequent cells in a new sheet.
Is that what you want? Or do you want each of the subranges beginning with "Event" and ending with "Laptop"?