Related
In the previous post you guys helped me to find out a solution in order to copy-paste cells.
By now I've got a slight different problem.
Here is it; I've got 2 different sheets;
worksheets("Food")
Worksheets("Numbers")
In worksheets("Food"), I've got the following board;
| Fruits | Vegetables |
| -------- | --------------|
| Banana | Carrots |
| Peach | Spinachs |
| Pineapple | Cauliflowers |
In worksheets("Numbers"), I've got this;
| Fruits | Numbers |
| -------- | --------- |
| Banana | 9 |
| Apple | 2 |
| Orange | 3 |
| Peach | 7 |
| Pineapple | 5 |
I'd like to search for each fruits from worksheets("Food") if they do exist in worksheets("Numbers"). If yes, then automatically insert a new column in worksheets("Food") between column Fruits and Vegetables named "Numbers".
After, picked up numbers beside each found fruits in worksheets("Numbers") and paste it in worksheets("Food") beside the matching fruit in the new created column.
Like this;
| Fruits |*Numbers* |Vegetables
| -------- |-------------- |------------
| Banana |**9** |Carrots
| Peach |**7** |Spinachs
| Pineapple |**5** |Cauliflowers
I've been trying to run a code doing this process but as I run it nothing happens ( no error occurs neither)...
Here is it;
Sub Add_Fruits_Numbers()
Dim lastlineFood As Long
Dim lastlineRef As Long
Dim j, i, compteur As Integer
Dim x As Long, rng As range
lastlineRef = Worksheets("Numbers").range("A" & rows.Count).End(xlUp).row
For j = 1 To lastlineRef
lastlineFood = Worksheets("Food").range("A" & rows.Count).End(xlUp).row
For i = 1 To lastlineFood
If range("A" & i).Value = Worksheets("Numbers").range("A" & j).Value Then
Set rng = Worksheets("Numbers").range("A1", range("A1").End(xlToRight))
For Each cell In rng
If cell.Value = "Fruits" Then
cell.EntireColumn.Offset(0, 1).Insert (xlShiftToRight)
End If
Next cell
Worksheets("Food").range("A" & i).Offset(, 1).Value = Worksheets("Numbers").range("A" & j).Offset(, 1)
End If
Next i
Next j
End Sub
I'd heavily appreciate your help once again, thank you !
Your code has some problems. It should raise an error on the line
Set rng = Worksheets("Numbers").range("A1", range("A1").End(xlToRight))
if the active sheet is not "Numbers". range("A1").End(xlToRight) refers the active sheet. The correct code should be:
Set rng = Worksheets("Numbers").range("A1", Worksheets("Numbers").range("A1").End(xlToRight))
Then, your code inserts a column in the "Numbers" sheet.
You should use Range("B" & i).EntireColumn.Insert instead of cell.EntireColumn.Offset(0, 1).Insert (xlShiftToRight). cell belongs to the range in "Numbers" sheet.
The code logic is wrong. The above sequence must be run only once. Otherwise it will insert a column for each match. "Fruits" will be there of each iteration.
Then everything is messed up and debugging more has no sense, no offence...
It is easier to show you a simpler/faster code, doing what (I understood) you want.
Please, try the next code:
Sub bringFruitsNo()
Dim shF As Worksheet, shN As Worksheet, lastRF As Long, lastRN As Long
Dim arrF, rngN As Range, mtch, i As Long, boolOK
Set shF = Sheets("Food")
Set shN = Sheets("Numbers")
lastRF = shF.Range("A" & shF.rows.count).End(xlUp).row 'last row
lastRN = shN.Range("A" & shN.rows.count).End(xlUp).row 'last row
If shF.Range("B1").value = "Numbers" Then boolOK = True 'check if the column has already been inserted in a previous run
arrF = shF.Range("A2:A" & lastRF).value 'put the first column in an array (for a faster iteration)
Set rngN = shN.Range("A2:A" & lastRN) 'set the range where to search for the fruit existence
For i = 1 To UBound(arrF) 'iterate between the array elements:
mtch = Application.match(arrF(i, 1), rngN, 0) 'if the fruit has bee found:
If IsNumeric(mtch) Then
'insert the new necessary column and mark the inserting event changing the boolean variable value
If Not boolOK Then shF.Range("B1").EntireColumn.Insert: shF.Range("B1").value = "Numbers": boolOK = True
shF.Range("B" & i + 1) = shN.Range("B" & mtch + 1).value 'Place the number in the new column
End If
Next i
End Sub
But, I think you maybe will need to use this code after the column has been inserted, and the code is checking if between "Fruits" and "Vegetables" a column named "Numbers" exists...
If not necessary, and always the code must insert a column between the first and the third column, that line can be deleted.
Hi and thanks in advance for any help. Extracting daily files that have the date in a cell. I need to use the date to find which week it falls into in a table which has start and end dates in two columns. There is more data in subsequent columns I need to extract once I know the row the date falls into. The cross reference table is in this format: The date variable (assigned to both string and date variables) that is picked up from the source needs to be compared to col's A and B to find out what row it would fit in then extract fiscal year (Col A) as well as short description (col F)
Cross Ref Table
The adjusted and renamed destination file looks like this
The functionality described here can be accomplished via cell formulas without resorting a VBA function. I included 2 possible solutions.
I have simplified the scenario a bit. Assume that the cross reference table (located in Sheet1 of a XR.xlsx file) only contains these 3 columns:
A B C
+--------------+---------------+---------------+
1 | PDWK_St_Date | PDWK_End_Date | Short_Descrip |
+--------------+---------------+---------------+
2 | 07-Nov-16 | 13-Nov-16 | P1W1 |
3 | 14-Nov-16 | 20-Nov-16 | P1W2 |
4 | 21-Nov-16 | 27-Nov-16 | P1W3 |
5 | 28-Nov-16 | 04-Dec-16 | P1W4 |
6 | 05-Dec-16 | 11-Dec-16 | P2W1 |
7 | 12-Dec-16 | 18-Dec-16 | P2W2 |
8 | 19-Dec-16 | 25-Dec-16 | P2W3 |
9 | 26-Dec-16 | 01-Jan-17 | P2W4 |
10 | 02-Jan-17 | 08-Jan-17 | P3W1 |
11 | 09-Jan-17 | 15-Jan-17 | P3W2 |
12 | 16-Jan-17 | 22-Jan-17 | P3W3 |
13 | 23-Jan-17 | 29-Jan-17 | P3W4 |
14 | 30-Jan-17 | 05-Feb-17 | P4W1 |
15 | 06-Feb-17 | 12-Feb-17 | P4W2 |
16 | 13-Feb-17 | 19-Feb-17 | P4W3 |
17 | 20-Feb-17 | 26-Feb-17 | P4W4 |
18 | 27-Feb-17 | 05-Mar-17 | P5W1 |
+--------------+---------------+---------------+
Solution 1 (simplified)
It only works if the date ranges are consecutive (i.e. start date = end date from previous row + 1 day) - his is the case in your cross reference table.
In your destination workbook, use VLOOKUP to refer to the cross reference table:
=VLOOKUP(B2,[XR.xlsx]Sheet1!$A$2:$C$18,3,TRUE)
The above formula is specific to row 2 in the destination table and assumes the "Business Date" is in column B (hence B2 in the 1st parameter), 2nd parameter is the lookup range, 3 in the 3rd parameter means the value to retrieve is in the 3rd column and TRUE allows date matching within a range (from start date to the next row's start date).
Note that the formula can be easily replicated to other rows, e.g. by dragging the fill handle (the small square in the cell's bottom-right corner).
Solution 2
In this approach, the business date is compared against both start and end dates from the cross-reference table. Instead of VLOOKUP, it uses INDEX and MATCH functions:
=INDEX([XR.xlsx]Sheet1!$C$2:$C$18,MATCH(1,(B2>=[XR.xlsx]Sheet1!$A$2:$A$18)*(B2<=[XR.xlsx]Sheet1!$B$2:$B$18),0),1)
Here, the business date (cell B2) is compared against both start and end date, the results are multiplied (equivalent to logical AND) and matched against 1 (i.e. TRUE).
IMPORTANT: After pasting this formula (e.g. into formula bar for cell C2) you need to hit Ctrl+Shift+Enter instead of the usual Enter. This is to indicate a so-called "array formula" (aka CSE formula); otherwise, our comparisons inside MATCH wouldn't work as intended. You may refer to this post for more info. The CSE formulas show surrounded by braces in the formula bar. The good news is that they can be replicated just like all other formulas.
The destination table will look similar to:
A B C
+------+---------------+-------------+
1 | Unit | Business Date | Short Descr |
+------+---------------+-------------+
2 | 1102 | 26-Aug-17 | #N/A |
3 | 1102 | 05-Jan-17 | P3W1 |
4 | 1102 | 06-Feb-17 | P4W2 |
5 | 1102 | 11-Nov-16 | P1W1 |
6 | 1102 | 02-Feb-17 | P4W1 |
7 | 1102 | 01-Oct-16 | #N/A |
+------+---------------+-------------+
Note that in case of solution 1, cell C2 would contain P5W1 instead of #N/A - this is because no end date was used in comparison.
The Function Provided by #PGTester worked great once a couple of issues were dealt with in the code:
1) Declarations: The declarations were all on one line for each type. This does not work in VBA as only the last variable is declared as intended and all previous ones are declared as variant. (ie, DIM adate, bdate, cdate as date) In this example only cdate is an actual date. Passing adate to the function resulted in a mismatch until the declarations were corrected. (This was pointed out by #Domenic)
2) Date formats: While all dates in the source file and the cross reference file were formatted as "yyyy-mmm-dd" prior to calling the function, Error 13, Type Mismatch still prevented the code from moving forward. Changing the format to "m-d-yyyy" on both the source file (done in code) and the cross reference table (manually prior to accessing) solved the issue and the following code worked as expected.
3) Pointing the function calls at the cross reference file for both the vlookup and rnglookup was done by building and setting variables to the pages needed. This simplified the selections when required.
Set variables for next steps
'
Set CRef = Workbooks.Open(refFILE)
Set shtJOB = CRef.Sheets("JobCross")
Set shtDATE = CRef.Sheets("fcalendar")
sht.Activate
Set rngJOBS = Range("i2:i" & lastRow)
Set rngJBGRP = shtJOB.Range("A1:b16")
Set rng = shtDATE.Range("A2:f210")
Completed code with both functions follows:
Sub CleanDaily_Labour()
'
' CleanDaily_Labour Macro
' RMDC Payroll Resarch (MU) Report prep
'
' Note the separate declarations for each variable
'
Dim myPath As String, fName As String, refFILE As String, job As String, _
JobGR As String, DateST As String, WKDay As String, PDWK As String
Dim CRef As Workbook, wkb As Workbook
Dim shtDATE As Worksheet, shtJOB As Worksheet, sht As Worksheet
Dim aDate As Date, fYR As Date
Dim fYear As Variant
Dim rng As Range, rngJOBS As Range, rngJBGRP As Range
Dim SC As Long, lastRow As Long, PD As Long, WK As Long
' Application.ScreenUpdating = False
myPath = Application.ActiveWorkbook.Path
'
' Get the file date and assign to variables
'
Range("D3").Select
**Selection.NumberFormat = "m-d-yyyy"**
aDate = Range("D3").Value
DateST = WorksheetFunction.Text(aDate, "YYYYMMDD")
WKDay = WorksheetFunction.Text(aDate, "DDD")
Selection.Copy
Range("D7").Select
ActiveSheet.Paste
'
' Rename and save the active workbook by date
' set wkb to new workbook name and assign calendar cross ref
'
fName = myPath & "\Daily_Labour_" _
& DateST & ".xlsx"
ActiveWorkbook.SaveAs fName, 51
Set wkb = Workbooks.Open(fName)
Set sht = wkb.Sheets("Sheet1")
refFILE = myPath & "\Cross_Ref_fCalendar.xlsx"
'
' Remove extra header info
'
Rows("1:5").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
'
' Insert Column to the left of Column D
'
Columns("E:G").Insert Shift:=xlToRight, _
CopyOrigin:=xlFormatFromRightOrBelow
'
' Update Headers that will be kept / used
'
Range("A1").Value = "FYear"
Range("E1").Value = "PD_WK"
Range("J1").Value = "JOB_GRP"
Range("F1").Value = "WKDay"
Range("G1").Value = "PD"
Range("H1").Value = "WK"
'
Rows("1:1").Select
With Selection
.HorizontalAlignment = xlCenter
End With
'
' Remove extra columns
'
Sheets("Sheet1").Range("K:K,M:P,R:AY").EntireColumn.Delete
'
' Get the last row and fill known columns
'
lastRow = Cells(Rows.Count, 1).End(xlUp).row
Range("d2:d" & lastRow).Value = aDate
Range("d2:d" & lastRow).NumberFormat = "m-d-yyyy"
Range("f2:f" & lastRow).Value = WKDay
'
' Set variables for next steps
'
Set CRef = Workbooks.Open(refFILE)
Set shtJOB = CRef.Sheets("JobCross")
Set shtDATE = CRef.Sheets("fcalendar")
sht.Activate
Set rngJOBS = Range("i2:i" & lastRow)
Set rngJBGRP = shtJOB.Range("A1:b16")
Set rng = shtDATE.Range("A2:f210")
'
' Loop through jobs in column i match job in shtJOB
' put matching group in row j (Use Function vLookupVBA)
'
For Each jRow In rngJOBS
jRow.Select
job = ActiveCell.Value
JobGR = VLookupVBA(job, rngJBGRP, Null)
ActiveCell.Offset(0, 1).Value = JobGR
'end for
Next jRow
'
'Save Progress during testing:
'
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs fName, 51
'
' Fill in date parameters from Cross Ref file for Business date
' Use function rngLOOKUP to update variables then set ranges to the variables
' May be more efficient to get row number from cross ref table instead - later.
'
shtDATE.Activate '(does not seem to affect)
'
fYear = rngLOOKUP(aDate, rng, 3)
PDWK = rngLOOKUP(aDate, rng, 6)
PD = rngLOOKUP(aDate, rng, 4)
WK = rngLOOKUP(aDate, rng, 5)
'
' Fill the columns with the variables (can likely bypass the variables and put on 1 line)- later
'
sht.Activate
Range("A2:A" & lastRow).Value = fYear
Range("E2:E" & lastRow).Value = PDWK
Range("G2:G" & lastRow).Value = PD
Range("H2:H" & lastRow).Value = WK
'
' Close reference file
'
Application.DisplayAlerts = False
CRef.Close False
'
' Cleanup, save and close workbooks
'
Application.DisplayAlerts = False
wkb.SaveAs fName, 51
'
' SQL call: Load to existing datbase (GDrive), use same format as Transactions
' ?? Get sales by day? vs maintain PDWK - Future
'
Application.DisplayAlerts = True
Application.ScreenUpdating = True
' wkb.Close.false
End Sub
Private Function VLookupVBA(what As Variant, lookupRng As Range, defaultValue As Variant) As Variant
Dim rv As Variant: rv = Application.VLookup(what, lookupRng, lookupRng.Columns.Count, False)
If IsError(rv) Then
VLookupVBA = "NULL"
Else
VLookupVBA = rv
End If
End Function
Public Sub UsageExample()
MsgBox VLookupVBA("ValueToFind", ThisWorkbook.Sheets("ReferenceSheet").Range("A:D"), "Not found!")
End Sub
Function rngLOOKUP(chkDate As Date, rngf As Range, theColumn As Long) As Variant
Dim acell As Range
'
For Each acell In rngf.Columns(1).Cells
If acell.Value <= chkDate And acell.Offset(0, 1).Value >= chkDate Then
rngLOOKUP = acell.Offset(0, theColumn - 1).Value
Exit Function
End If
Next acell
rngLOOKUP = "#Nothing"
End Function
This custom function is similar to Vlookup where it will compare the first two columns of a range as a date, and if the input date falls in the range, it will return the respective column.
Function rngLOOKUP(aDate As Date, rng As Range, theColumn As Long) As Variant
Dim acell As Range
For Each acell In rng.Columns(1).Cells
If acell.Value <= aDate And acell.Offset(0, 1).Value >= aDate Then
rngLOOKUP = acell.Offset(0, theColumn - 1).Value
Exit Function
End If
Next acell
rngLOOKUP = "#Nothing"
End Function
In this excel file, you can see it in action. Or see below screenshot. The highlight cell has the custom formula.
I have a dataset that consists of 5 different variables. As shown below.
Value1 Value 2 Value 3 Value 4 Value 5
1200.08031 104.9940186 28.05707932 23.90201187 1198.955811
1200.01948 105.0005951 28.05075455 23.88057899 1198.984619
1199.9152 105.0007782 28.04256058 23.86779976 1199.18042
1199.90651 105.0114594 28.05139923 23.90410423 1199.148926
1200.01079 104.9975433 28.05404663 23.89129448 1198.660034
1199.97603 104.9940186 28.0475502 23.91586685 1198.932129
1199.89782 105.0007782 28.04875183 23.87851715 1198.928833
1200.01948 105.0056458 28.04198837 23.91583633 1199.087524
1199.87175 105.0026855 28.04278946 23.91485214 1198.896851
1199.97603 105.0054626 28.04265976 23.9235096 1199.426514
Each of these variables has around 15,000 data points. To reduce the number of data points I want to average every ten data points into one data point and assign this value to a cell on another sheet. I want it to look like:
Value1Avg Value 2Avg Value 3Avg Value 4Avg Value 5Avg
1200.08031 104.9940186 28.05707932 23.90201187 1198.955811
I cannot get the average function to loop through every ten data points.
I have tried to run a loop that goes through each column and averages the values and places them on a different sheet, but I am not incrementing the variables correctly I believe.
Set wb = ThisWorkbook
Set sht1 = wb.Sheets("RawData")
Set sht2 = wb.Sheets("FilteredData")
ii = 2
j = 11
dd = 2
k = 20
n = 1
LastRow = sht1.Range("A:A").Find("*", searchdirection:=xlPrevious).Row
For i = 1 To LastRow
Set Myrange = sht1.Range("E" & ii, "E" & j)
sht2.Range("A" & n).Value =Application.WorksheetFunction.Average(Myrange)
Set Myrange = sht1.Range("B" & ii, "B" & j)
sht2.Range("B" & n).Value = Application.WorksheetFunction.Average(Myrange)
Set Myrange = sht1.Range("C" & ii, "C" & j)
sht2.Range("C" & n).Value = Application.WorksheetFunction.Average(Myrange)
Set Myrange = sht1.Range("H" & ii, "H" & j)
sht2.Range("E" & n).Value = Application.WorksheetFunction.Average(Myrange)
Set Myrange = sht1.Range("D" & ii, "D" & j)
sht2.Range("D" & n).Value = Application.WorksheetFunction.Average(Myrange)
ii = ii + 10
j = j + 10
n = n + 1
Next i
I expect to go to sheet 2 and see the averages, but I get:
"Run-time error '1004': Method 'Range' of object '_Worksheet' failed"
Here is a potential alternative that may be a little easier to follow by making use of nested loops. This way you do not have to complete the average for each column one by one, instead you can just have your action line written once situated inside a row & column loop.
Simplifying variables will also make this easier to update / debug in the future.
Sub Jeeped()
Dim rd As Worksheet: Set rd = ThisWorkbook.Sheets("RawData")
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("FilteredData")
Dim LR As Long
LR = rd.Range("A" & rd.Rows.Count).End(xlUp).Row
Dim c As Long 'Column Loop
Dim r As Long 'Row Loop
Dim x As Long 'Paste counter
x = 2
Dim TempAverage As Range
For r = 2 To LR Step 10
For i = 1 To 5 '<-- (Columns A - D)
Set TempAverage = rd.Range(rd.Cells(r, i), rd.Cells(r + 9, i))
ws.Cells(x, i).Value = Application.WorksheetFunction.Average(TempAverage)
Next i
x = x + 1
Next r
End Sub
assumes your variables span Columns A:D on RawData and that the values will be pasted on FilterdData on Columns A:D as well. You can modify the loops to place them in the correct location
https://i.stack.imgur.com/RKcpe.png
I got an excel file with a data source sheet. To be able to parse the data at the next step I need to add 1 to every value and get it into a new sheet. The thing is, that there are multiple values per cell, each separated by comma, and this number is not static. Adding the +1 at a later point is sadly not an option so I need to do this in excel.
Source sheet Prepared data sheet
| MyValues | | MyValues + 1 |
|------------| |--------------|
| 0,1,2,3 | | 1,2,3,4 |
| 3 | -----> | 4 |
| 2,4,6 | | 3,5,7 |
| 1 | | 2 |
Here's helper column based solution. I have assumed data starts from cell A2 and concatenation formula in cell B2. I have considered case of 15 maximum values.
In cell C2, following formula shall be put:
=IFERROR((TRIM(MID(SUBSTITUTE(","&$A2,",",REPT(" ",99)),COLUMNS($A$1:A1)*99,99))/1)+1,"")
This shall be copied across (till column Q) and down (till last row of your data).
Then apply concatenation formula as below in cell B2:
=SUBSTITUTE(TRIM(CONCATENATE(C2," ",D2," ",E2," ",F2," ",G2," ",H2," ",I2," ",J2," ",K2," ",L2," ",M2," ",N2," ",O2," ",P2," ",Q2))," ",",")
shall work for Excel Version 2007 or higher.
Here is one way doing this (assuming Excel 2016 with TEXTJOIN()):
Formula in B1:
=IFERROR(TRIM(MID(SUBSTITUTE($A1,",",REPT(" ",LEN($A1))),(COLUMN()-2)*LEN($A1)+1,LEN($A1)))+1,"")
Drag down and sideways (could be 15 columns if need be)
Formula in G1:
=TEXTJOIN(",",TRUE,B1:E1)
Drag down
You don't need a VBA solution but in your case a UDF could also be a nice way to do this, for example like so:
Function AddVal(RNG As Range, VAL As Double) As String
Dim ARR1() As String, ARR2() As String, X As Double
If RNG.Cells.Count = 1 Then
ARR = Split(RNG.Value, ",")
For X = LBound(ARR) To UBound(ARR)
ReDim Preserve ARR2(X)
ARR2(X) = ARR(X) + VAL
Next X
If IsEmpty(ARR2) Then
AddVal = "No hits"
Else
AddVal = Join(ARR2, ",")
End If
Else
AddVal = "No valid range"
End If
End Function
Call through =AddVal(A1;1)
You can change the 1 for another number if you want to add more than just 1.
I try to create a VBA code (i know that VBA is not tagged) to fulfill this task.
Option Explicit
Sub test()
Dim LastRow As Long, i As Long, Count As Long, j As Long
Dim str As Variant, strNew As String
With ThisWorkbook.Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRow
Count = Len(.Range("A" & i).Value) - Len(Replace(.Range("A" & i).Value, ",", ""))
str = Split(.Range("A" & i).Value, ",")
If Count > 0 Then
For j = 0 To Count
str(j) = str(j) + 1
If .Range("B" & i).Value = "" Then
.Range("B" & i).Value = str(j)
Else
.Range("B" & i).Value = .Range("B" & i).Value & "," & str(j)
End If
Next j
Else
.Range("B" & i).Value = .Range("A" & i).Value + 1
End If
Next i
End With
End Sub
Results:
Objective: I'm looking to find the reference row number of data points from filtered series that have been scatter plotted from two separate sheets.
I'm following these guides, with little success:
Excel VBA loop through visible filtered rows
Excel vba - find row number where colum data (multiple clauses)
Scenario: I have two Sheets containing data in identical tabulated format:
+-----+-------------+---------+---------+-------+
| Row | Description | X-value | Y-value | Score |
+-----+-------------+---------+---------+-------+
| 1 | "Something" | 3.4 | 4.5 | 7.0 |
| 2 | "Something" | 2.3 | 2.4 | 5.6 |
| ... | ... | ... | ... | ... |
| 100 | "Something" | 6.5 | 4.2 | 8.0 |
+-----+-------------+---------+---------+-------+
x-val and y-val from each sheet has been scatter plotted as separate series on the same chart.
I have a VBA script that on mouse hover on the chart returns the series index, x, and y coordinates of the specific data point (Arg1, ser.Values, ser.XValues):
Private Sub Chart_MouseMove(ByVal Button As Long, ByVal Shift As Long, ByVal x As Long, ByVal y As Long)
Dim ElementID As Long
Dim Arg1 As Long
Dim Arg2 As Long
Dim chart_data As Variant
Dim chart_label As Variant
Dim last_point As Long
Dim chrt As Chart
Dim ser As Series
Dim score As Double
Dim desc As String
On Error Resume Next
Me.GetChartElement x, y, ElementID, Arg1, Arg2
Application.ScreenUpdating = False
Set chrt = ActiveChart
Set ser = ActiveChart.SeriesCollection(Arg1)
'x and y values
chart_data = ser.Values
chart_label = ser.XValues
If the list is unfiltered it seems the series' point index matches the row number so I can get a reference to the row and extract info quite easily:
If Arg1 = 1 Then
score = Sheet1.Cells(Arg2 + 1, "E").Value
desc = Sheet1.Cells(Arg2 + 1, "B").Value
End If
If Arg1 = 2 Then
score = Sheet2.Cells(Arg2 + 1, "E").Value
desc = Sheet2.Cells(Arg2 + 1, "B").Value
End If
Complexity: Each sheet filters on score and dynamically update the chart, so the resulting row numbers in each sheet may not contiguous. Some rows are hidden.
The above indices no longer match the correct row, so my code returns the wrong information.
Eg. Scores > 6
+-----+-------------+---------+---------+-------+
| Row | Description | X-value | Y-value | Score |
+-----+-------------+---------+---------+-------+
| 1 | "Something" | 3.4 | 4.5 | 7.0 |
| 100 | "Something" | 6.5 | 4.2 | 8.0 |
+-----+-------------+---------+---------+-------+
Outcome: I would like to use the x, y values to search the visible list on each sheet and retrieve the row number. So that I can then retrieve the description and score to pipe into my mouse-over pop-up message.
I'm a novice in VBA and guidance is appreciated.
Update 1: Showing code to do mouse-hover and adopting DisplayName's answer. It does not work for all data points, and displays a blank box. Currently trying to debug. When comparing to my original code with no filtering on rows.
Clarification: X values (and Y) could be the same. Where there are duplicate X and Y returning the first match would be ok.
Set txtbox = ActiveSheet.Shapes("hover")
If ElementID = xlSeries And Arg1 <= 2 Then
' Original code that only works on un-filtered rows in Sheet 1 & 2
' If Arg1 = 1 Then
' score = Sheet1.Cells(Arg2 + 1, "E").Value
' desc = Sheet1.Cells(Arg2 + 1, "B").Value
' ElseIf Arg1 = 2 Then
' score = Sheet2.Cells(Arg2 + 1, "E").Value
' desc = Sheet2.Cells(Arg2 + 1, "B").Value
' End If
' Code from DisplayName
With Worksheets(Choose(Arg1, Sheet1.Name, Sheet2.Name)) ' reference Sheet1 if Arg1=1 and Sheet2 if Arg1=2
With .Range("C2", .Cells(.Rows.Count, "C").End(xlUp)).Find(what:=chart_label(Arg2), LookIn:=xlValues, lookat:=xlWhole) ' search reference referenced sheet x-values range for current x-value
If .Offset(, 1).Value = chart_data(Arg2) Then 'check y-value
score = .Offset(, 2).Value ' assign 'score' the value of found cell offset two columns to the right
desc = .Offset(, -1).Value ' assign 'desc' the value of found cell offset one column to the left
End If
End With
End With
If Err.Number Then
Set txtbox = ActiveSheet.Shapes.AddTextbox _
(msoTextOrientationHorizontal, x - 150, y - 150, 300, 50)
txtbox.Name = "hover"
txtbox.Fill.Solid
txtbox.Fill.ForeColor.SchemeColor = 9
txtbox.Line.DashStyle = msoLineSolid
chrt.Shapes("hover").TextFrame.Characters.Text = "Y: " & Application.WorksheetFunction.Text(chart_data(Arg2), "?.?") & _
", X: " & Application.WorksheetFunction.Text(chart_label(Arg2), "?.?") & _
", Score: " & Application.WorksheetFunction.Text(score, "?.?") & ", " & desc
With chrt.Shapes("hover").TextFrame.Characters.Font
.Name = "Arial"
.Size = 12
.ColorIndex = 16
End With
last_point = Arg2
End If
txtbox.Left = x - 150
txtbox.Top = y - 150
Else
txtbox.Delete
End If
Application.ScreenUpdating = True
End Sub
Update 2: As Tim Williams noted there is no way to get around this without looping through the range. I combined his pseudocode with DisplayName's example to get the desired behavior where x, y is compared to get the score and description. Here is the code that worked:
With Worksheets(Choose(Arg1, Sheet1.Name, Sheet2.Name))
For Each row In .Range("C2", .Cells(.Rows.Count, "C").End(xlUp)).SpecialCells(xlCellTypeVisible)
If row.Value = chart_label(Arg2) And row.Offset(, 1).Value = chart_data(Arg2) Then
score = row.Offset(, 2).Value
desc = row.Offset(, -1).Value
Exit For
End If
Next row
End With
I wish I could split the bounty between Tim Williams and Display Name. As I can only choose one the award goes to Tim.
You can do something like this:
'called from your event class using Arg1 and Arg2
Sub HandlePointClicked(seriesNum As Long, pointNum As Long)
Dim vis As Range, c As Range, i As Long, rowNum As Long
Dim sht As Worksheet
' which sheet has the source data?
Set sht = GetSheetFromSeriesNumber(seriesMum)
'Get only the visible rows on the source data sheet
' (adjust to suit your specific case...)
Set vis = sht.Range("A2:A100").SpecialCells(xlCellTypeVisible)
'You can't index directly into vis
' eg. vis.Cells(pointNum) may not work as you might expect
' so you have (?) to do something like this loop
For Each c In vis.Cells
i = i + 1
If i = pointNum Then rowNum = c.Row
Next c
Debug.Print rowNum '<< row number for the activated point
End Sub
As reparation of my earlier attempt to answer without going into details of your question and to prevent my deleted answer to be viewed by experts, I am offering another solution. But before going into codes and all, I must acknowledge that the best solution is already provided by #Tim Williams and think only his answer is worthy to be accepted (till date). I found no other option to get row numbers without looping.
I only attempting to put the pieces together and integrating with your code. I have taken following liberties
Used class module as directly coding Chart_MouseMove may become troublesome while modifying/working with chart.
Chart is placed on the worksheet only
Used a stationary Textbox already placed on the chart to avoid deleting & recreating the same. It may cause problem in run time error
Avoided disabling Screen update and Error bypass.
You may please modify the code according to your requirement.
Now first insert a class module named CEvent. In the class module add
Public WithEvents Scatter As Chart
Private Sub Scatter_MouseMove(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long)
Dim ElementID As Long
Dim Arg1 As Long
Dim Arg2 As Long
Dim chart_data As Variant
Dim chart_label As Variant
Dim last_point As Long
Dim chrt As Chart
Dim Ser As Series
Dim score As Double
Dim desc As String
Dim VRng, Cl As Range, SerStr As String, part As Variant, Txt As Shape
'On Error Resume Next
Set chrt = ActiveChart
chrt.GetChartElement X, Y, ElementID, Arg1, Arg2
'Application.ScreenUpdating = False
'x and y values
If ElementID = xlSeries And Arg1 <= 2 Then
Set Ser = ActiveChart.SeriesCollection(Arg1)
SerStr = Ser.Formula
part = Split(SerStr, ",")
Set VRng = Range(part(1)).SpecialCells(xlCellTypeVisible)
Vrw = 0
For Each Cl In VRng.Cells
Vrw = Vrw + 1
If Vrw = Arg2 Then
Exit For
End If
Next
score = Cl.Offset(, 2).Value
desc = Cl.Offset(, -1).Value
chart_data = Cl.Value
chart_label = Cl.Offset(, 1).Value
Set Txt = ActiveSheet.Shapes("TextBox 2")
'Txt.Name = "hover"
Txt.Fill.Solid
Txt.Fill.ForeColor.SchemeColor = 9
Txt.Line.DashStyle = msoLineSolid
Txt.TextFrame.Characters.Text = "Y: " & chart_label & ", X: " & chart_data & ", Score: " & score & ", " & vbCrLf & desc
With Txt.TextFrame.Characters.Font
.Name = "Arial"
.Size = 12
.ColorIndex = 16
End With
last_point = Arg2
'Txtbox.Left = X - 150
'Txtbox.Top = Y - 150
Else
'Txt.Visible = msoFalse
End If
'Application.ScreenUpdating = True
End Sub
Then in a standard module
Dim XCEvent As New CEvent
Sub InitializeChart()
Set XCEvent.Scatter = Worksheets(1).ChartObjects(1).Chart
Worksheets(1).Range("I25").Value = "Scatter Scan Mode On"
Worksheets(1).ChartObjects("Chart 1").Activate
End Sub
Sub ReleaseChart()
Set XCEvent.Scatter = Nothing
Worksheets(1).Range("I25").Value = "Scatter Scan Mode Off"
End Sub
The sub InitializeChart() & ReleaseChart() may be assigned to buttons placed on the worksheet near the chart. May please modify Sheet names, addresses, Chart name, Textbox names etc suitably. It is working with make shift filtered data
Hope It will be useful
you have to find the cell with the current x-value and then offset from it
so substitute:
If Arg1 = 1 Then
score = Sheet1.Cells(Arg2 + 1, "E").Value
desc = Sheet1.Cells(Arg2 + 1, "B").Value
End If
If Arg1 = 2 Then
score = Sheet2.Cells(Arg2 + 1, "E").Value
desc = Sheet2.Cells(Arg2 + 1, "B").Value
End If
with:
With Worksheets(Choose(Arg1, Sheet1.Name, Sheet2.Name)) ' reference Sheet1 if Arg1=1 and Sheet2 if Arg1=2
With .Range("C2", .Cells(.Rows.Count, "C").End(xlUp)).Find(what:=chart_label(Arg2), LookIn:=xlValues, lookat:=xlWhole) ' search reference referenced sheet x-values range for current x-value
score = .Offset(, 2).Value ' assign 'score' the value of found cell offset two columns to the right
desc = .Offset(, -1).Value ' assign 'desc' the value of found cell offset one column to the left
End With
End With