Background info:
I have a listing of 5000+ error messages in this format:
"999999 16 901 F SMITH, Smith FT 1 1.0 Additional Leave hours -4.0000 exceed entitlement plus pro-rata -4.0000"
I have been able to categorise them using a macro, so "Additional Leave hours exceed entitlement plus pro-rata" for example.
From there I'm trying to extract the two numbers.
I can do it manually using these formulas:
=MID(J3,SEARCH("hours ",J3)+5,SEARCH("exceed",J3)-SEARCH("hours ",J3)-6)
=TRIM(RIGHT(SUBSTITUTE(J3," ",REPT(" ",LEN(J3))),LEN((J3))))
But this is where i'm stuck, incorporating that logic in the macro and having it loop through the full list.
This was my first attempt:
If InStr(myString, "Additional Leave hours ") > 0 And InStr(myString, "exceed entitlement plus pro-rata") Then
'set category
Cells(x, 6).Value = "Additional Leave hours exceed entitlement plus pro-rata"
'first number
Cells(x, 8).ForumlaR1C1 = "=MID(RC[2],SEARCH(""hours "",RC[2])+5,SEARCH(""exceed"",RC[2])-SEARCH(""hours "",RC[2])-6"
'second number
Cells(x, 9).FormulaR1C1 = "=TRIM(RIGHT(SUBSTITUTE(RC[2],"" "",REPT("" "",LEN(RC[2]))),LEN((RC[2]))))"
'first minus second
Cells(x, 7).FormulaR1C1 = "=SUM(RC[2]-RC[1]"
End If
From there I have been able to use .Select & .Active cell, and it works but not efficiently:
'first number
Cells(x, 8).Select
ActiveCell.FormulaR1C1 = "=MID(RC[2],SEARCH(""hours"",RC[2])+5,SEARCH(""exceed"",RC[2])SEARCH(""hours "",RC[2])-6)"
Any help would be appreciated, thanks in advance.
Idea is to process all the strings in an array (so that it's faster, compared to writing/reading cells 1 by 1), use RegExp to extract the 2 numbers into an array which will be used to paste into the previous 2 columns. Finally insert the SUM formula into the column before:
Sub Test()
Const inputStartRow As Long = 1
Const inputCol As String = "J"
Const regexPattern As String = "Additional Leave hours ([-\d.]{1,}) exceed entitlement plus pro-rata ([-\d.]{1,})"
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'Change name accordingly
Dim regex As Object
Set regex = CreateObject("VBScript.RegExp")
With regex
.Pattern = regexPattern
.Global = False
End With
'==== Get last row of the input column and set to range
Dim inputLastRow As Long
inputLastRow = ws.Cells(ws.Rows.Count, inputCol).End(xlUp).Row
Dim inputRng As Range
Set inputRng = ws.Range(ws.Cells(inputStartRow, inputCol), ws.Cells(inputLastRow, inputCol))
'==== Populate the array with the input range's value
Dim inputArr As Variant
inputArr = inputRng.Value
Dim outputArr() As String
ReDim outputArr(1 To UBound(inputArr, 1), 1 To 2) As String
'==== Loop through the array and extract the 2 numbers
Dim i As Long
For i = 1 To UBound(inputArr, 1)
If InStr(inputArr(i, 1), "Additional Leave hours ") > 0 And InStr(inputArr(i, 1), "exceed entitlement plus pro-rata") Then
If regex.Test(inputArr(i, 1)) Then
Dim regexMatch As Object
Set regexMatch = regex.Execute(inputArr(i, 1))(0)
outputArr(i, 1) = regexMatch.SubMatches(0)
outputArr(i, 2) = regexMatch.SubMatches(1)
End If
End If
Next i
'==== Insert the extraction # Input column - 1/ -2
Dim outputRng As Range
Set outputRng = inputRng.Offset(, -2).Resize(, 2)
outputRng.Value = outputArr
Set outputRng = Nothing
'==== Add in SUM formula # Input Column - 3
Dim sumRng As Range
Set sumRng = inputRng.Offset(, -3)
sumRng.Formula = "=SUM(" & ws.Cells(inputStartRow, sumRng.Column + 1).Address(RowAbsolute:=False) & "-" & ws.Cells(inputStartRow, sumRng.Column + 2).Address(RowAbsolute:=False) & ")"
Set sumRng = Nothing
End Sub
Related
Alright, this is a very specific question. I have an excel macro written that takes a web URL, delimits it, transposes it, and then adds adjacent columns that describe the information in the originally transposed columns. Now, I need to add something to my macro that will loop through and check if the first character of one cell matches one of the first 4 characters of another cell. If it does, I need to concatenate strings from the descriptive columns to new cells. I'll illustrate this below:
3,435,201,0.5,%22type%25202%2520diabetes%22,0 Node type 2 diabetes
4,165,97,0.5,%22diet%22,0 Node diet
5,149,248,0.5,%22lack%2520of%2520exercise%22,2 Node lack of exercise
6,289,329,0.5,%22genetics%22,3 Node genetics
7,300,71,0.5,%22blood%2520pressure%2520%22,5 Node blood pressure
7,3,-7,1,0 Arrow +
4,3,-21,1,0 Arrow +
5,3,-22,1,0 Arrow +
6,3,-34,1,0 Arrow +
,7%5D Tail
I added color to make the concept of the problem more easily visualized. In row one of the first column, we see a red 3 that corresponds to 'type 2 diabetes'. In the fifth row of the first column, we see a blue 7 that corresponds to 'blood pressure'. These are both node objects, as the adjacent column signifies. In the sixth cell of the first column we see a blue 7 and a red 3. This indicates that an arrow (also signified by adjacent column) is connecting blood pressure to diabetes. In the next column over, we see an orange plus sign, which indicates this is a positive relationship.
The goal is to populate the next column over with "blood pressure + type diabetes", as I demonstrated in the image. So, I need some code to check the first characters in each node cell, and then compare them to the first 4 characters of each arrow cell. When an arrow that matches two of the nodes is found, I need the code to populate the row next to the + signs with a concatenated string comprised of the names of the nodes pertaining to that arrow, as well as the + sign between them (it's possible that it could also be a minus sign, but one isn't present in this example). Any pointers? I can't wrap my head around this. Edited to add Data
Here is the code of my current macro:
Sub Delimit_Transpose()
Cells.Replace What:="],[", Replacement:="#", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
ActiveCell.FormulaR1C1 = "=RIGHT(R[-1]C,LEN(R[-1]C)-36)"
Dim i As Long, strTxt As String
Dim startP As Range
Dim xRg As Range, yRg As Range
On Error Resume Next
Set xRg = Application.InputBox _
(Prompt:="Range Selection...", _
Title:="Delimit Transpose", Type:=8)
i = 1
Application.ScreenUpdating = False
For Each yRg In xRg
If i = 1 Then
strTxt = yRg.Text
i = 2
Else
strTxt = strTxt & "," & yRg.Text
End If
Next
Application.ScreenUpdating = True
Set startP = Application.InputBox _
(Prompt:="Paste Range...", _
Title:="Delimit Transpose", Type:=8)
ary = Split(strTxt, "#")
i = 1
Application.ScreenUpdating = False
For Each a In ary
startP(i, 1).Value = Replace(Replace(a, "[", ""), "]", "")
i = i + 1
Next a
i = 1
For Each a In ary
If Len(a) > 13 Then
startP.Offset(i - 1, 1).Value = "Node"
ElseIf Len(a) < 13 And Len(a) > 6 Then
startP.Offset(i - 1, 1).Value = "Arrow"
Else
startP.Offset(i - 1, 1).Value = "Tail"
End If
i = i + 1
Next a
Dim openPos As Integer
Dim closePos As Integer
Dim midBit As String
i = 1
n = 5
For Each a In ary
openPos = InStr(a, ",%22")
On Error Resume Next
closePos = InStr(a, "%22,")
On Error Resume Next
midBit = Mid(a, openPos + 1, closePos - openPos - 1)
On Error Resume Next
If openPos <> 0 And Len(midBit) > 0 Then
startP.Offset(i - 1, 2).Value = Replace(Replace(midBit, "%22", ""), "%2520", " ")
ElseIf Len(a) < 13 And InStr(a, "-") = 4 Then
startP.Offset(i - 1, 2).Value = "'-"
ElseIf Len(a) < 7 Then
startP.Offset(i - 1, 2).Value = " "
Else
startP.Offset(i - 1, 2).Value = "+"
End If
i = i + 1
n = n + 1
Next a
Application.ScreenUpdating = True
End Sub
This is my approach.
There's room for a lot of improvements, but is a rough code that should get you started.
Read the code's comments and adapt it to fit your needs.
EDIT: I updated the code to match the sample worksheet you uploaded, build the first column range dinamically, validate if commas appear in the first column cell so no error is raised.
As I said in the comments, it's better easier to debug if you call one procedure from the other, instead of merging them.
Code:
Option Explicit
Public Sub StoreConcatenate()
' Basic error handling
On Error GoTo CleanFail
' Define general parameters
Dim targetSheetName As String
targetSheetName = "Test space" ' Sheet holding the data
Dim firstColumnLetter As String
firstColumnLetter = "C" ' First column holding the numbers
Dim firstColumnStartRow As Long
firstColumnStartRow = 7
' With these three parameters we'll build the range address holding the first column dynamically
' Set reference to worksheet
Dim targetSheet As Worksheet
Set targetSheet = ThisWorkbook.Worksheets(targetSheetName)
' Find last row in column (Modify on what column)
Dim firstColumnlastRow As Long
firstColumnlastRow = targetSheet.Cells(targetSheet.Rows.Count, firstColumnLetter).End(xlUp).Row
' Build range of first column dinamically
Dim firstColumnRange As Range
Set firstColumnRange = targetSheet.Range(firstColumnLetter & firstColumnStartRow & ":" & firstColumnLetter & firstColumnlastRow)
' Loop through first column range cells
Dim valueCell As Range
For Each valueCell In firstColumnRange
' Check if cell contains "," in the second position in string
If InStr(valueCell.Value, ",") = 2 Then
' Store first digit of cell before ","
Dim firstDigit As Integer
firstDigit = Split(valueCell.Value, ",")(0)
' Check if cell contains "," in the fourth position in string
If InStr(3, valueCell.Value, ",") = 4 Then
' Store second digit of cell after ","
Dim secondDigit As Integer
secondDigit = Split(valueCell.Value, ",")(1)
End If
' Store second colum type
Dim secondColumnType As String
secondColumnType = valueCell.Offset(, 1).Value
' Store third column value
Dim thirdColumnValue As String
thirdColumnValue = valueCell.Offset(, 2).Value
' Store nodes values (first digit and second column type)
Select Case secondColumnType
Case "Node"
Dim nodeValues() As Variant
Dim nodeCounter As Long
ReDim Preserve nodeValues(nodeCounter)
nodeValues(nodeCounter) = Array(firstDigit, thirdColumnValue)
nodeCounter = nodeCounter + 1
Case "Arrow"
Dim matchedNodeFirstValue As String
Dim matchedNodeSecondValue As String
matchedNodeFirstValue = IsInArrayReturnItem(firstDigit, nodeValues)(1)
matchedNodeSecondValue = IsInArrayReturnItem(secondDigit, nodeValues)(1)
If matchedNodeFirstValue <> vbNullString And matchedNodeSecondValue <> vbNullString Then
valueCell.Offset(, 3).Value = matchedNodeFirstValue & Space(1) & thirdColumnValue & Space(1) & matchedNodeSecondValue
End If
End Select
End If
Next valueCell
CleanExit:
Exit Sub
CleanFail:
Debug.Print "Something went wrong: " & Err.Description
Resume CleanExit
End Sub
' Credits: https://stackoverflow.com/a/38268261/1521579
Public Function IsInArrayReturnItem(stringToBeFound As Integer, arr As Variant) As Variant
Dim i
For i = LBound(arr) To UBound(arr)
If arr(i)(0) = stringToBeFound Then
IsInArrayReturnItem = arr(i)
Exit Function
End If
Next i
IsInArrayReturnItem = Array(vbNullString, vbNullString)
End Function
Let me know if it works
It appears that you are concatenating the lookups based on the
first and second integers,
where the second column = "Arrow"
If that is the case, I suggest:
Read the data table into a VBA array for faster processing
I am assuming your data is ordered as you show it, with all the Node entries at the start.
if that is not the case, then loop twice -- once to find the Nodes, and second time to concatenate the Arrow data.
Read the diagnoses into a dictionary for fact lookup.
if column2 = "Arrow" then concatenate the lookups of the first and second integers
Write back the data
Note: As written, this will overwrite the original table destroying any formulas that might be there. If needed, you could easily modify it to only overwrite the necessary area.
Note2 Be sure to set a reference (under Tools/References) to Microsoft Scripting Runtime, or change the Dictionary declaration to late-binding.
Regular Module
'set reference to Microsoft Scripting Runtime
Option Explicit
Sub Dx()
Dim WS As Worksheet
Dim rngData As Range, c As Range, vData As Variant
Dim dDx As Dictionary
Dim I As Long, sKey As String, dxKeys As Variant
'Get the data range
Set WS = ThisWorkbook.Worksheets("sheet1")
With WS
'assume table starts in A1 and is three columns wide
Set rngData = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=3)
'read into variant array for faster processing
vData = rngData
End With
'create dictionsry for dx lookups
Set dDx = New Dictionary
For I = 2 To UBound(vData, 1)
Select Case vData(I, 2)
Case "Node"
sKey = Split(vData(I, 1), ",")(0) 'first comma-separated number
If dDx.Exists(sKey) Then
MsgBox "duplicate diagnostic key. Please correct the data"
Exit Sub
End If
dDx.Add Key:=sKey, Item:=vData(I, 3)
Case "Arrow"
dxKeys = Split(vData(I, 1), ",")
vData(I, 3) = dDx(dxKeys(0)) & " + " & dDx(dxKeys(1))
End Select
Next I
'reWrite the table
Application.ScreenUpdating = False
rngData = vData
End Sub
Didn't know how to phrase my problem into a simple question, sorry!
I have a spreadsheet that is in the incorrect format for what I need to do.
As you can see, each row is a species of fish, while the column is a unique transect, composed of (a) year, (b) site, (c) reef zone and finally (d) replicate number. The number on the overlap is the number of times this species was recorded in that specific transect.
What I would like to do, is generate a new sheet where each record of a fish on the original spreadsheet is an entire row. This would give a spreadsheet where each individual fish that was recorded now gets its own line, and it would look like this:
I have very little understanding of anything more than basic Excel, so any help with this would be gratefully appreciated!
Depending on how big your data set is, code might not be necessary. It looks like you could flash fill most of the columns, then sort and paste in your specific transects and species. If you felt you still needed code, then a simple For Next loop would suffice to write your required unique values.
i.e.:
For i = 2 to LastRow
If
'code
Then
Next i
Const startRow As Integer = 5
Const newSheet As String = "TransposedData"
Sub makeDownwards()
Dim row As Integer, ws As Worksheet, ows As Worksheet
Dim oRow As Integer, col As Integer, repNumber As Integer, i As Integer
Dim fName As String, sName As String, year As String, site As String, none As String, transect As String
row = startRow
Set ws = ActiveSheet
Set ows = ThisWorkbook.Worksheets.Add(after:=ActiveSheet)
ows.Name = newSheet
oRow = 2
ows.Range("A1").Resize(1, 6) = Split("Fish Name ,Fish Spicies ,Year ,Site ,None ,Transect", ",")
ows.Range("A1:F1").Font.Bold = True
ows.Range("A1:F1").BorderAround xlContinuous, xlThin
ows.Range("A1:F1").HorizontalAlignment = xlCenter
Do While (ws.Cells(row, 1) <> "")
row = row + 1
col = 3
fName = ws.Cells(row, 1)
sName = ws.Cells(row, 2)
Do While ws.Cells(1, col) <> ""
repNumber = ws.Cells(row, col).Value
year = ws.Cells(1, col)
side = ws.Cells(2, col)
none = ws.Cells(3, col)
transect = ws.Cells(4, col)
For i = 1 To repNumber
ows.Range("A" & oRow).Resize(1, 6) = Array(fName, sName, year, side, none, transect)
oRow = oRow + 1
Next
col = col + 1
Loop
Loop
End Sub
On tab1 I have a pivot table . When I double click subtotal number 256 on that pivot table, a new worksheet pops up with the details. Everything is just as expected.
On tab2, I have a formula in the field A1 . This formula refers to the subtotal value in the pivot (from tab1)
=GETPIVOTDATA("theId",tab1!$A$1)
A1 shows 256 . . . exactly as in the pivot table .
I need to be able to doulble click this A1 field and see a pop up worksheet with the details (as if I was clicking the pivot table)
The problem is GETPIVOTDATA returns a value only and no link or indirect reference
How can I do this ?
Sorry for the delay, but the weekend was in the middle.
Well here is my answer to how to show the data from a pivot, just with doble click inside a cell, in another sheet that have, the GETPIVOTDATA formula.
Note that in my pivot, I set to "Repeat all items labels" and use a old style pivot.
See the pictures:
For repeat all items labels
and the old style works better for me, and most of all, the macro (VBA)
That been said, let's code!!
All this inside a regular module.
Sub getDataFromFormula(theFormulaSht As Worksheet, formulaCell As Range)
Dim f
Dim arrayF
Dim i
Dim L
Dim iC
Dim newArrayF() As Variant
' Dim rowLables_Sort()
' Dim rowLables_Sort_i()
Dim T As Worksheet
Dim rowRange_Labels As Range
Dim shtPivot As Worksheet
Dim shtPivotName
Dim thePivot As PivotTable
Dim numRows
Dim numCols
Dim colRowRange As Range
Dim colRowSubRange As Range
Dim First As Boolean
Dim nR
Dim nC
Dim myCol
Dim myRow
Dim theRNG As Range
Set T = theFormulaSht 'the sheet where the formula is
'#####################################
'my example formula
'=GETPIVOTDATA("EURO",P!$A$3,"Descripcion","Ingresos Netos de Terceros ,","Mes","July","CuentaCrest","310100","Descripción Crest","Net revenue third parties","Producto","AFR","SubProducto","AFRI","TM1","Net Revenue")
'#####################################
T.Activate 'go!
f = formulaCell.Formula 'get the formula
f = Replace(f, "=GETPIVOTDATA", "") 'delete some things...
f = Replace(f, Chr(34), "")
f = Replace(f, ",,", ",") 'in my data, there is ,, and I need to fix this...
f = Right(f, Len(f) - 1) 'take the formual without parentesis.
f = Left(f, Len(f) - 1)
'####################################
'Restult inside "f"
'EURO,P!$A$3,Descripcion,Ingresos Netos de Terceros ,Mes,July,CuentaCrest,310100,Descripción Crest,Net revenue third parties,Producto,AFR,SubProducto,AFRI,TM1,Net Revenue
'####################################
arrayF = Split(f, ",")
'####################################
'Restult inside arrayF
'EURO,P!$A$3,Descripcion,Ingresos Netos de Terceros ,Mes,July,CuentaCrest,310100,Descripción Crest,Net revenue third parties,Producto,AFR,SubProducto,AFRI,TM1,Net Revenue
'####################################
shtPivotName = arrayF(1) 'set (just) the name of the sheet with the pivot
shtPivotName = Left(shtPivotName, InStr(1, shtPivotName, "!") - 1)
Set shtPivot = Sheets(shtPivotName) 'set the var with the sheet that contents the pivot
Set thePivot = shtPivot.PivotTables(1) 'store the pivot inside
If shtPivot.Visible = False Then 'if the sheet with the pivot is hidden... set visible.
shtPivot.Visible = xlSheetVisible
End If
shtPivot.Activate 'go there!
numRows = thePivot.RowRange.Rows.Count - 1 'the number of rows of the row Range
numCols = thePivot.RowRange.Columns.Count 'here the columns of the same range
Set rowRange_Labels = thePivot.RowRange.Resize(1, numCols)
'with Resize get jus the labels above the RowRange (see the picture (1))
iC = -1
First = True
For Each i In rowRange_Labels 'run the labels
iC = -1 'set the counter
If First Then 'check the flag to see if is the firt time...
First = False 'set the flag to FALSE to go the other part of the IF next time
Set colRowRange = Range(Cells(i.Row, i.Column), Cells(i.Row + numRows - 1, i.Column))
Do
iC = iC + 1 'just to set the counter
Loop While arrayF(iC) <> i.Value 'stop when gets equals and keep the counter
'in the array the values are just strings,
'but we know that is key-value pairs thats why adding +1 to iC we get the real info
'below the label
nR = colRowRange.Find(arrayF(iC + 1)).Row 'just used here
nC = WorksheetFunction.CountIf(colRowRange, arrayF(iC + 1)) + nR - 1 'here we count to set the range
Set colRowSubRange = Range(Cells(nR, i.Column), Cells(nC, i.Column)) 'set the range
myRow = colRowSubRange.Row 'here we get the row of the value
Else
Do 'this is simpler
iC = iC + 1
Loop While arrayF(iC) <> i.Value 'againg...
nR = colRowSubRange.Offset(, 1).Find(arrayF(iC + 1)).Row 'use the SubRange to get others subranges
nC = WorksheetFunction.CountIf(colRowSubRange.Offset(, 1), arrayF(iC + 1)) + nR - 1
Set colRowSubRange = Range(Cells(nR, i.Column), Cells(nC, i.Column))
myRow = colRowSubRange.Row 'idem
End If
Next i
numCols = thePivot.DataBodyRange.Columns.Count 'other part of the pivot... (see the picture (2))
Set theRNG = thePivot.DataBodyRange.Resize(1, numCols) 'just take the above labels
Set theRNG = theRNG.Offset(-1, 0)
iC = -1
For Each L In thePivot.ColumnFields 'for every label...
Do
iC = iC + 1
Loop While L <> arrayF(iC) 'idem
myCol = theRNG.Find(arrayF(iC + 1), , , xlWhole).Column
'always will be just one column...
Next L
Cells(myRow, myCol).ShowDetail = True 'here is the magic!!! show all the data
End Sub
And inside the Worksheet code this:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Left(Target.Formula, 13) = "=GETPIVOTDATA" Then 'Check if there a formula GetPivotData
getDataFromFormula Sheets(Me.Name), Target
End If
End Sub
See this picture to understand what happends to the formula:
The formula is split it as you can see f, into arrayF.
I'm sure you will need to do some changes, but this is very functional and basic, and will be easy to findout what you need.
Also:
This part of code helps me a lot to understand what the pivot had. Using the same data and pivot, I ran the code:
Sub rangePivot()
Dim Pivot As PivotTable
Dim rng As Range
Dim P As Worksheet
Dim D As Worksheet
Dim S As Worksheet
Dim i
Set P = Sheets("P") 'the sheet with the pivot
Set D = Sheets("D") 'the sheet with the data
Set S = Sheets("S") 'the sheet with the cells with the formula
S.Activate 'go
Set Pivot = P.PivotTables("PivotTable1") 'store the pivot here...
For i = 1 To Pivot.RowFields.Count
Cells(i, 1).Value = Pivot.RowFields(i)
Next i
For i = 1 To Pivot.ColumnFields.Count
Cells(i, 2).Value = Pivot.ColumnFields(i)
Next i
For i = 1 To Pivot.DataFields.Count
Cells(i, 3).Value = Pivot.DataFields(i)
Next i
For i = 1 To Pivot.DataLabelRange.Count
Cells(i, 4).Value = Pivot.DataLabelRange.Address(i)
Next i
For i = 1 To Pivot.DataLabelRange.Count
Cells(i, 4).Value = Pivot.DataLabelRange.Address(i)
Next i
For i = 1 To Pivot.DataFields.Count
Cells(i, 5).Value = Pivot.DataFields(i)
Next i
For i = 1 To Pivot.DataFields.Count
Cells(i, 5).Value = Pivot.DataFields(i)
Next i
For i = 1 To Pivot.DataFields.Count
Cells(i, 5).Value = Pivot.DataFields(i)
Next i
For i = 1 To Pivot.DataBodyRange.Count
Cells(i, 6).Value = Pivot.DataBodyRange.Address(i)
Next i
For i = 1 To Pivot.DataLabelRange.Count
Cells(i, 7).Value = Pivot.DataLabelRange.Address(i)
Next i
Cells(1, 8).Value = Pivot.ColumnGrand
Cells(1, 9).Value = Pivot.RowRange.Address
Cells(1, 11).Value = Pivot.TableRange1.Address
Cells(1, 12).Value = Pivot.TableRange2.Address
End Sub
And, as usual, if you need som help & improvement contact me. Hope this help other too.
If you want to do VBA you could set up an event like here:
http://www.ozgrid.com/forum/showthread.php?t=49050
Once you have that set up you need to develop some code that determines where the subtotal cell is (because those are prone to change). Once you have that address you can use Range([subtotal]).ShowDetail = True
I need to find a way to split some data on excel: e.g.
If a cell has the following in: LWPO0001653/1654/1742/1876/241
All of the info after the / should be LWPO000... with that number.
Is there anyway of separating them out and adding in the LWPO000in? So they come out as LWPO0001653
LWPO0001654
etc etc
I could do manually yes, but i have thousands to do so would take a long time.
Appreciate your help!
Here is a solution using Excel Formulas.
With your original string in A1, and assuming the first seven characters are the one's that get repeated, then:
B1: =LEFT($A1,FIND("/",$A1)-1)
C1: =IF(LEN($A1)-LEN(SUBSTITUTE($A1,"/",""))< COLUMNS($A:A),"",LEFT($A1,7)&TRIM(MID(SUBSTITUTE(MID($A1,8,99),"/",REPT(" ",99)),(COLUMNS($A:A))*99,99)))
Select C1 and fill right as far as required. Then Fill down from Row 1
EDIT: For a VBA solution, try this code. It assumes the source data is in column A, and puts the results adjacent starting in Column B (easily changed if necessary). It works using arrays within VBA, as doing multiple worksheet read/writes can slow things down. It will handle different numbers of splits in the various cells, although could be shortened if we knew the number of splits was always the same.
Option Explicit
Sub SplitSlash()
Dim vSrc As Variant
Dim rRes As Range, vRes() As Variant
Dim sFirst7 As String
Dim V As Variant
Dim COL As Collection
Dim I As Long, J As Long
Dim lMaxColCount As Long
Set rRes = Range("B1") 'Set to A1 to overwrite
vSrc = Range("a1", Cells(Rows.Count, "A").End(xlUp))
'If only a single cell, vSrc won't be an array, so change it
If Not IsArray(vSrc) Then
ReDim vSrc(1 To 1, 1 To 1)
vSrc(1, 1) = Range("a1")
End If
'use collection since number of columns can vary
Set COL = New Collection
For I = 1 To UBound(vSrc)
sFirst7 = Left(vSrc(I, 1), 7)
V = Split(vSrc(I, 1), "/")
For J = 1 To UBound(V)
V(J) = sFirst7 & V(J)
Next J
lMaxColCount = IIf(lMaxColCount < UBound(V), UBound(V), lMaxColCount)
COL.Add V
Next I
'Results array
ReDim vRes(1 To COL.Count, 1 To lMaxColCount + 1)
For I = 1 To UBound(vRes, 1)
For J = 0 To UBound(COL(I))
vRes(I, J + 1) = COL(I)(J)
Next J
Next I
'Write results to sheet
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2))
With rRes
.EntireColumn.Clear
.Value = vRes
.EntireColumn.AutoFit
End With
End Sub
I'm clearly missing the point :-) but anyway, in B1 and copied down to suit:
=SUBSTITUTE(A1,"/","/"&LEFT(A1,7))
Select ColumnB, Copy and Paste Special, Values over the top.
Apply Text to Columns to ColumnB, Delimited, with / as the delimiter.
There's a couple of ways to solve this. The quickest is probably:
Assuming that the data is in column A:
Highlight the column, go to Data>>Text To Columns
Choose "Delimited" and in the "Other" box, put /
Click ok. You'll have your data split into multiple cells
Insert a column at B and put in the formula =Left(A1, 7)
Insert a column at C and pit in formula =Right(A1, Length(A1)-7)
You'll now have Column B with your first 7 characters, and columns B,C,D,E,F, etc.. with the last little bit. You can concatenate the values back together for each column you have with =Concatenate(B1,C1), =Concatenate(B1,D1), etc..
A quick VBa, which does nearly the same thing that #Kevin's does as well. I wrote it before I saw his answer, and I hate to throw away work ;)
Sub breakUpCell()
Dim rngInput As Range, rngInputCell As Range
Dim intColumn As Integer
Dim arrInput() As String
Dim strStart As String
Dim strEnd As Variant
'Set the range for the list of values (Assuming Sheet1 and A1 is the start)
Set rngInput = Sheet1.Range("A1").Resize(Sheet1.Range("A1").End(xlDown).Row)
'Loop through each cell in the range
For Each rngInputCell In rngInput
'Split up the values after the first 7 characters using "/" as the delimiter
arrInput = Split(Right(rngInputCell.Value, Len(rngInputCell.Value) - 7), "/")
'grab the first 7 characters
strStart = Left(rngInputCell.Value, 7)
'We'll be writing out the values starting in column 2 (B)
intColumn = 2
'Loop through each split up value and assign to strEnd
For Each strEnd In arrInput
'Write the concatenated value out starting at column B in the same row as rngInputCell
Sheet1.Cells(rngInputCell.Row, intColumn).Value = strStart & strEnd
'Head to the next column (C, then D, then E, etc)
intColumn = intColumn + 1
Next strEnd
Next rngInputCell
End Sub
Here is how you can do it with a macro:
This is what is happening:
1) Set range to process
2) Loop through each cell in range and check it isn't blank
3) If the cell contains the slash character then split it and process
4) Skip the first record and concatenate "LWPO000" plus the current string to adjacent cells.
Sub CreateLWPO()
On Error Resume Next
Application.ScreenUpdating = False
Dim theRange
Dim cellValue
Dim offset As Integer
Dim fields
'set the range of cells to be processed here
Set theRange = range("A1:A50")
'loop through each cell and if not blank process
For Each c In theRange
offset = 0 'this will be used to offset each item found 1 cell to the right (change this number to this first column to be populated)
If c.Value <> "" Then
cellValue = c.Value
If InStr(cellValue, "/") > 0 Then
fields = Split(cellValue, "/")
For i = 1 To UBound(fields)
offset = offset + 1
cellValue = "LWPO000" & fields(i)
'if you need to pad the number of zeros based on length do this and comment the line above
'cellValue = "LWPO" & Right$(String(7, "0") & fields(i), 7)
c.offset(0, offset).Value = cellValue
Next i
End If
End If
Next
Application.ScreenUpdating = True
End Sub
I have a set of descriptions that contain ID numbers arranged into a column. For example:
Column A
This is a description with the ID number in it ID12345.
This is a description ID66666 with the ID number in it.
This is ID99999 a description with the ID number in it.
The Id numbers are always in the format "IDXXXXX" I'd like to somehow trim away all the text in each of these cells and leave just that ID number.
My thoughts:
Can this be somehow done by finding a string like "ID?????" and setting that to a variable, then replacing the contents of the cell with that variable? Or by erasing all characters in a cell -except- for "ID?????"
Any help would be appreciated, thanks.
This code I wrote for you will iterate through all items in Column A. It will split all the words in each cell into an array. If the word is 7 or 8 characters long then it could potentially be an IDxxxxx. It will perform a few checks to see if it really matches an IDxxxxx syntax. In case it does it will replace the contents of the cell with just the ID dropping all the remaining text.
Sub ReplaceContentWithIDs()
Dim ws As Worksheet
Set ws = Sheets("Sheet1") ' or your sheet name
Dim rng As Range
Dim i&, lr&, j&
Dim arr
Dim str$
lr = ws.Range("A" & Rows.Count).End(xlUp).Row
' starting from 1 - if you have headers change to 2
For i = 1 To lr
Set rng = ws.Range("A" & i)
arr = Split(CStr(rng.Value), " ")
For j = LBound(arr) To UBound(arr)
str = arr(j)
If (Len(str) = 7) Or (Len(str) = 8) Then
If (StrComp(Left(str, 2), "ID", vbTextCompare) = 0) And _
IsNumeric(Right(Left(str, 7), 5)) Then
' found it
If Len(str) = 8 Then
rng.Value = Left(str, 7)
ElseIf Len(str) = 7 Then
rng.Value = str
End If
End If
End If
Next j
Set rng = Nothing
Next i
End Sub
I took this as a challenge to my intellect, and given that it is the end of the day, after seeing the formulas by Aladdin and pgc01 on Mr Excel forums I did a little work and came up with this CSE (Array formula):
=IF(ISNUMBER(LOOKUP(9.99999999999999E+307,SEARCH({"ID0","ID2","ID3","ID4","ID5","ID6","ID7","ID8","ID9"},A1))),MID(A1,LOOKUP(9.99999999999999E+307,SEARCH({"ID0","ID2","ID3","ID4","ID5","ID6","ID7","ID8","ID9"},A1)),7),"")
I also had some luck with this CSE Array formula:
=IF(ISNUMBER(SEARCH("ID"&{1,2,3,4,5,6,7,8,9},$A$1)),MID(A$1,SEARCH("ID"&{1,2,3,4,5,6,7,8,9},$A$1),7))