I have a text data set that I need to reformat before I can use it. It's currently a text file that I've imported into Excel. Each record currently spans three rows but is in one column. I need to transform it so it's one row with three columns.
The sample below is how my data is currently structured. It shows three records out of 2,000+. The 'Row' column is just for reference and not actually in my data.
Row | Column
1 | File Number: 001
2 | File Code: ABC
3 | File Description: Text file
4 | File Number: 002
5 | File Code: DEF
6 | File Description: Text file
7 | File Number: 003
8 | File Code: GHI
9 | File Description: Text file
Just to clarify, row 1 to 3 would be one record. Row 4 to 6 would be the second record. The third record is from row 7 to 9. Every record in my data is currently split into three rows.
I want to reformat it so it looks something like this:
Row | File Number | File Code | File Description
1 | 001 | ABC | Text
2 | 002 | DEF | Text
3 | 003 | GHI | Text
Again, the row column is just for reference and I don't need it in my reformatted data. Copy and pasting does not appear to be a good option.
Is there a quick way to transform this?
You can use VBA to do this. Code like this might help you for this particular situation.
Option Explicit
Sub Test()
' Let's make the tabular structure in column C, D and E
' C D E
' File Number Code Description
Dim CurrentRow As Integer
CurrentRow = 2 ' Read from A2
Dim WriteRow As Integer
WriteRow = 2 ' Write to C2
Do
' if we see empty data in column A, then we are done with our work
If Len(Trim(Range("A" & CurrentRow))) = 0 Then Exit Do
' make 3 rows of data into 3 columns in a single row
Range("C" & WriteRow).Value = Trim(Replace(Range("A" & CurrentRow).Text, "File Number:", ""))
Range("D" & WriteRow).Value = Trim(Replace(Range("A" & CurrentRow + 1).Text, "File Code:", ""))
Range("E" & WriteRow).Value = Trim(Replace(Range("A" & CurrentRow + 2).Text, "File Description:", ""))
' increment our reading and writing markers
CurrentRow = CurrentRow + 3
WriteRow = WriteRow + 1
Loop
End Sub
Feel free to test out.
As a reference: this uses TextToColumns, AutoFilter, and places results on a new sheet
Option Explicit
Sub mergeRows()
Dim ws As Worksheet, fld As Variant, i As Long, cel As Range
fld = Split("File Number,File Code,File Description", ",")
Worksheets.Add After:=Worksheets(Worksheets.Count)
Set ws = Worksheets(Worksheets.Count)
Application.ScreenUpdating = False
With Worksheets(1)
Set cel = .Range("A1")
.UsedRange.Columns(1).TextToColumns Destination:=cel.Cells(1, 2), _
DataType:=xlDelimited, _
Other:=True, OtherChar:=":"
.Rows(1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
cel.Cells(0, 2) = "Col 1": cel.Cells(0, 3) = "Col 2"
.UsedRange.AutoFilter
For i = 0 To 2
.UsedRange.AutoFilter Field:=cel.Cells(1, 2).Column, Criteria1:=fld(i)
.UsedRange.Columns(cel.Cells(1, 3).Column).Copy ws.Cells(1, i + 1)
ws.Cells(1, i + 1) = fld(i)
Next
.UsedRange.AutoFilter
.UsedRange.Offset(, 1).EntireColumn.Delete
cel.Cells(0, 2).EntireRow.Delete
End With
ws.UsedRange.Columns.AutoFit
Application.ScreenUpdating = True
End Sub
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.
I have 3 worksheets (user1, user2, result). Each sheet has three columns (A: System_ID, B: Comment, C: Last Modified Time).
The code does this:
Gets maximum last modified time between user1 and user2 in column c.
The result is to get that comment in column b (adjacent to max time found in col c)
put the result (comment) in column b in resut sheet
Simply the comment with last modified time wins and gets pasted in result WS.
Anyways, my problem is that I only can index-match if both indexes in column A have the same sorting/order.
I need to match all records in column A even if they have different row.number or row index.
How to index-match no matter the order in column A
Sub Get_LastModified_Here()
Application.EnableEvents = False
Dim Location1 As Workbook
Set Location1 = GetWorkbook("C:\Users\HP\Desktop\User_1.xlsb")
Dim Location2 As Workbook
Set Location2 = GetWorkbook("C:\Users\HP\Desktop\User_2.xlsb")
Dim SourceCell As Range, SourceRange As Range, CurrentRange As Range
Dim rngTarget As Range
Dim strAdr As String
Dim vSource As Variant, vTarget As Variant, vCurrent As Variant
Dim i As Long
Set SourceRange = Workbooks("User_2.xlsb").Sheets("Data").Range("A2:" & "A1607")
With SourceRange
Set SourceRange = .Resize(.Rows.Count, .Columns.Count + 3)
End With
strAdr = SourceRange.Address
Set rngTarget = Workbooks("User_1.xlsb").Worksheets("Data").Range(strAdr)
Set CurrentRange = ThisWorkbook.Worksheets("Data").Range(strAdr).Offset(0, 1)
vSource = SourceRange
vTarget = rngTarget
vCurrent = CurrentRange
For i = 1 To UBound(vSource, 1)
'Match Column A
If vSource(i, 1) = vTarget(i, 1) Then
'Check max time in Column C (user1 vs user2)
If vSource(i, 3) > vTarget(i, 3) Then
'Get max comment from ((user max)) in column B (result ws)
vCurrent(i, 1) = vSource(i, 2)
ElseIf vSource(i, 3) < vTarget(i, 3) Then
vCurrent(i, 1) = vTarget(i, 2)
ElseIf vSource(i, 3) = vTarget(i, 3) Then
vCurrent(i, 1) = vSource(i, 2)
End If
End If
Next i
SourceRange = vSource
rngTarget = vTarget
CurrentRange = vCurrent
Application.EnableEvents = True
End Sub
Here is a detailed explanation of the issue (I apologize for CAPS letters):
User1 Sheet
I have the SYSTEM_ID in ## Row 1 ##
System_ID
Comment
LastModTime
ID_1
User1 notes
09/12/2020 10:00:01 PM
User2 Sheet
I have the SAME SYSTEM_ID in ## Row 2 ##
System_ID
Comment
LastModTime
ID_1
User2 notes
09/12/2020 10:00:02 PM
This is what I GET in Result Sheet
I have the SAME SYSTEM_ID but in ## Row 3 ##
System_ID
Comment
LastModTime
ID_1
This is what I Want in Result Sheet
I have the SAME SYSTEM_ID but in ## Row 3 ##
System_ID
Comment
LastModTime
ID_1
User2 notes
09/12/2020 10:00:02 PM
What our codes CAN do
Get the comment based on the last modified time, ONLY IF "ID_1" is on THE SAME ROW #. i have tried it (didn't work)
What our codes CAN'T do
Get the comment based on the last modified time, EVEN IF "ID_1" is on A DIFFERENT ROW #. this is where I need help?
EDIT to confirm that the assumptions match:
Sheet User1:
| Id | Comment | LastMod |
| --- | ------- | --------|
| 3 | S1 Comm3| 2 |
| 2 | S1 Comm2| 8 |
| 1 | S1 Comm1| 6 |
Sheet User2:
| Id | Comment | LastMod |
| --- | ------- | --------|
| 1 | S2 Comm1| 3 |
| 2 | S2 Comm2| 4 |
| 3 | S2 Comm3| 8 |
Expected Output:
Id
Comment
NOTES
1
S1 Comm1
Id 1 highest mod is on sheet 1
2
S1 Comm2
Id 2 highest mod is on sheet 2
3
S2 Comm3
Id 3 highest mod is on sheet 3
One option is to build up the result set into a separate collection, and then populate your result set when finished. Since this is an operation that involved multiple lookups (checking to see if a system Id has already been visited), I like to use dictionary objects. These offer highly performant lookup operations.
I'm going to post a much simplified example below that you can hopefully use for your purposes. The code below assumes that the SystemId column is a unique key that maps an entry in sheet1 to an entry in sheet2. It also assumes that each systemId appears once per sheet. If not, it can be tweaked to support that.
The code basically loops through the range and checks if the rows in both sheets have matching system ID. If so, it adds that row to the dictionary, using the ID as a key, and a two element array containing the comment and the last mod time.
If they don't match, it checks each entry against the dictionary to see if that systemID was already visited (earlier on the other sheet). If so, it compares the entries and keeps the most recent mod time, otherwise, it leaves it as is.
Try to work through it and let us know if you need additional help.
Sub Tester()
Dim oDict As Object
Dim a(0 To 1)
Dim sUser1 As Worksheet
Dim sUser2 As Worksheet
Set oDict = CreateObject("Scripting.Dictionary")
Set sUser1 = Sheets("User1")
Set sUser2 = Sheets("User2")
'Here I will assume that both ranges will always
'be the same length. I'm also hardcoding in the
'needed rows. You can use whichever logic
'works best for you to determine how to capture
'all rows in both sheets
For i = 2 To 8
'Two possibilities here:
' 1. The SystemId in both sheets match and
' can be directly compared
' 2. They differ and will each be checked
' to see if they already exist in the dict.
'You can bypass this and just treat each of the
'ranges individually, but I think it would be
'slightly more performant the way I'm doing it.
'
'Also, this assumes that each SystemId will only
'appear once in each sheet, and is a true Primary Key
If sUser1.Cells(i, 1).Value = sUser2.Cells(i, 1) Then
If sUser1.Cells(i, 3).Value > sUser2.Cells(i, 3).Value Then
MergeEntryToDictionary oDict, sUser1.Cells(i, 1).Value, _
sUser1.Cells(i, 2).Value, sUser1.Cells(i, 3).Value
Else
MergeEntryToDictionary oDict, sUser2.Cells(i, 1).Value, _
sUser2.Cells(i, 2).Value, sUser2.Cells(i, 3).Value
End If
Else
'In case they don't match, check each entry against the
'dictionary to see if the systemId has already been added.
'If not, then add it. Otherwise, compare the last mod date
'of the entry to the current, and update if needed.
MergeEntryToDictionary oDict, sUser1.Cells(i, 1).Value, _
sUser1.Cells(i, 2).Value, sUser1.Cells(i, 3).Value
MergeEntryToDictionary oDict, sUser2.Cells(i, 1).Value, _
sUser2.Cells(i, 2).Value, sUser2.Cells(i, 3).Value
End If
Next i
'Below prints back to sheet
Dim k As Variant
Dim n As Long
n = 2
For Each k In oDict.keys
Sheets("result").Cells(n, 1).Value = k
Sheets("result").Cells(n, 2).Value = oDict(k)(0)
Sheets("result").Cells(n, 3).Value = oDict(k)(1)
n = n + 1
Next k
End Sub
Function MergeEntryToDictionary(ByRef oDict As Object, _
SystemId As String, _
sComment As String, _
LastModTime As Double) As Boolean
Dim a(0 To 2)
If oDict.exists(SystemId) Then
If LastModTime > oDict(SystemId)(1) Then
a(0) = sComment
a(1) = LastModTime
oDict(SystemId) = a
End If
Else
a(0) = sComment
a(1) = LastModTime
oDict.Add SystemId, a
End If
MergeEntryToDictionary = True
End Function
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 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