I have some lines (rows) in excel in the following form :
I need to transform it to the following form :
I'm not a good user of MS Excel and I am using the french version.
Thanks
Give this a try
Option Explicit
Public Sub MergeRows()
Dim rng As Range
Dim dict As Object
Dim tmp As Variant
Dim i As Long, j As Long
Dim c, key
Set dict = CreateObject("Scripting.dictionary")
dict.CompareMode = vbTextCompare
' Change this to where your source data is
With Sheet17
Set rng = .Range(.Cells(2, 10), .Cells(.Cells(.Rows.Count, 10).End(xlUp).Row, 10))
End With
For Each c In rng
If Not dict.exists(c.Value2) Then
ReDim tmp(1 To 3)
dict.Add key:=c.Value2, Item:=tmp
End If
j = 1
tmp = dict(c.Value2)
Do
If Not c.Offset(0, j).Value2 = vbNullString Then tmp(j) = c.Offset(0, j).Value2
j = j + 1
Loop Until j > UBound(tmp)
dict(c.Value2) = tmp
Next c
' Change this to where you want your output
With Sheet17.Range("A2")
i = 0
For Each key In dict.keys
.Offset(i, 0).Value2 = key
.Offset(i, 1).Resize(, UBound(dict(key))) = dict(key)
i = i + 1
Next key
End With
End Sub
Fun problem, here's my take using formulae but there's sure to be solutions out there that are better.
It uses three helper columns to the right of your options' columns:
1-Identify which option is chosen by finding the (first) non-blank cell in the row (as per these instructions). Put the first range as your header row (option1, option2, ... optionn) and the second range as your row from option1 through optionn. It should look something like this: =INDEX($K$1:$M$1,MATCH(FALSE,ISBLANK(K2:M2),0)) and note that it should be an array formula (ctrl+shift+enter)
2-Use a simple index+match to register the choice. Assuming the first helper column is in column N, this is: =INDEX(k2:m2,MATCH(n2,$k$1:$m$1,0))
3-Concatenate the address and option name to make it possible to look up the address-option combination. This is simply: =J2&N2
Once this is done, you create a simple table with only single Addresses in the left most column and Options as a header row (depending on the number of addresses, you might want to use a pivot table to populate them). Then you have an index-match to find your results:
=INDEX($O$2:$O$6,MATCH($J9&K$8,$P$2:$P$6,0)).
And you should be done.
Related
Dear Team Could you please help me on below case
In the excel file we have name and department with available resources
First table we have details and second table need to fill with number or just comments YES or NO.
I have tried with IF formula it will not be helpful because cells keep moving based on second table which changes daily
Formula which I have tried no useful
If(A2&b1=a12&b11,if(b2<0,"No","Yes"),"Match not found")
Could you please help me. VBA am new no idea how this case can be helpful
You may want to transform the first table from the cross-table layout to tabular (aka unpivot):
e.g. 1st column=name, 2nd column=department
then add 3rd column as combo: “name/department” (or any other delimiter in between)
| a1 | 1011 | a1/1011 | 1 |
| a1 | 1033 | a1/1033 | 3 |
etc.
In the second crosstable you could use vlookup/xlookup:
match criteria is the respective combo of the name to the left and the department on the column header (e.g. A12&”/“&”B11)
Match (vlookup) this against 3rd column from first table (in tabular layout) to get back then value (or “yes”) - this should work dynamically based on the value in the respective column and row headers (and not dependent on the position of the cells)
Use PowerQuery to unpivot and add 3rd column and replace the numbers with “yes” to create tabular version of first table
I asked a clarification question, but you were not interested in answering it.
Anyhow, I prepared an answer which should be fast enough, using arrays and a dictionary. It uses the ranges you show us in the picture. I wanted to configure it for using two sheets and automatically calculating the last row of each.
It assumes that in the first table there are unique names. In the second one may be as many names as you want, in any sorting order.
Please, test the next code and send some feedback:
Sub matchNames()
Dim sh As Worksheet, lastR As Long, dict As Object
Dim rngGlob As Range, rngRow As Range, arrGlob, arrSrc, i As Long, j As Long, arrYes, arrRet
Set sh = ActiveSheet
lastR = 7 ' if can be calculated, if two sheets will be used: sh.Range("A" & sh.rows.count).End(xlUp).row
Set rngGlob = sh.Range("A1:G" & lastR): arrGlob = rngGlob.Value2
arrSrc = sh.Range("B11:D11").Value2 'the array of numbers to be matched in the global array
arrRet = sh.Range("A12:D17").Value2 'the array of the range to return (Yes...)
'place the "Yes" string where the numbers exist in an array and load the dictinary:
Set dict = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(arrGlob)
On Error Resume Next 'for the case of no any value on the processed row:
Set rngRow = rngGlob.rows(i).Offset(0, 1).Resize(1, rngGlob.Columns.count - 1).SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If Not rngRow Is Nothing Then arrYes = getYes(rngGlob, rngRow, arrSrc)
dict(arrGlob(i, 1)) = IIf(IsArray(arrYes), arrYes, vbNullString) 'place the array containing Yes as Item
Erase arrYes
Next i
'place the dictionary arrays value in the array to be returned:
For i = 1 To UBound(arrRet)
arrYes = dict(arrRet(i, 1))
If UBound(arrYes) = UBound(arrSrc, 2) - 1 Then
For j = 0 To UBound(arrYes)
arrRet(i, j + 2) = arrYes(j)
Next j
Else
'place empty strings, to clean eventually older values whchid does not correspond, anymore
For j = 0 To UBound(arrSrc, 2) - 1: arrRet(i, j + 2) = "": Next j
End If
Next i
sh.Range("A12").Resize(UBound(arrRet), UBound(arrRet, 2)).Value2 = arrRet
End Sub
Function getYes(rngGlob As Range, rng As Range, arr) As Variant 'it returns the "Yes" array per name
Dim rngH As Range, arrY, i As Long, cel As Range, mtch
ReDim arrY(UBound(arr, 2) - 1)
Set rngH = rng.Offset(-(rng.row - 1))
For Each cel In rngH.cells
mtch = Application.match(cel.value, arr, 0)
If IsNumeric(mtch) Then
arrY(mtch - 1) = "Yes"
End If
Next cel
getYes = arrY
End Function
I am new to VBA and am trying to copy the column from Row 2 onwards where the column header (in Row 1) contains a certain word- "Unique ID".
Currently what I have is:
Dim lastRow As Long
lastRow = ActiveWorkbook.Worksheets("Sheets1").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Sheets1").Range("D2:D" & lastRow).Copy
But the "Unique ID" is not always in Column D
You can try following code, it loops through first row looking for a specified header:
Sub CopyColumnWithHeader()
Dim i As Long
Dim lastRow As Long
For i = 1 To Columns.Count
If Cells(1, i) = "Unique ID" Then
lastRow = Cells(Rows.Count, i).End(xlUp).Row
Range(Cells(2, i), Cells(lastRow, i)).Copy Range("A2")
Exit For
End If
Next
End Sub
When you want to match info in VBA you should use a dictionary. Additionally, when manipulating data in VBA you should use arrays. Although it will require some learning, below code will do what you want with minor changes. Happy learning and don't hesitate to ask questions if you get stuck:
Option Explicit
'always add this to your code
'it will help you to identify non declared (dim) variables
'if you don't dim a var in vba it will be set as variant wich will sooner than you think give you a lot of headaches
Sub DictMatch()
'Example of match using dictionary late binding
'Sourcesheet = sheet1
'Targetsheet = sheet2
'colA of sh1 is compared with colA of sh2
'if we find a match, we copy colB of sh1 to the end of sh2
'''''''''''''''''
'Set some vars and get data from sheets in arrays
'''''''''''''''''
'as the default is variant I don't need to add "as variant"
Dim arr, arr2, arr3, j As Long, i As Long, dict As Object
'when creating a dictionary we can use early and late binding
'early binding has the advantage to give you "intellisense"
'late binding on the other hand has the advantage you don't need to add a reference (tools>references)
Set dict = CreateObject("Scripting.Dictionary") 'create dictionary lateB
dict.CompareMode = 1 'textcompare
arr = Sheet1.Range("A1").CurrentRegion.Value2 'load source, assuming we have data as of A1
arr2 = Sheet2.Range("A1").CurrentRegion.Value2 'load source2, assuming we have data as of A1
'''''''''''''''''
'Loop trough source, calculate and save to target array
'''''''''''''''''
'here we can access each cell by referencing our array(<rowCounter>, <columnCounter>
'e.g. arr(j,i) => if j = 1 and i = 1 we'll have the values of Cell A1
'we can write these values anywhere in the activesheet, other sheet, other workbook, .. but to limit the number of interactions with our sheet object we can also create new, intermediant arrays
'e.g. we could now copy cel by cel to the new sheet => Sheets(arr(j,1).Range(... but this would create significant overhead
'so we'll use an intermediate array (arr3) to store the results
'We use a "dictionary" to match values in vba because this allows to easily check the existence of a value
'Together with arrays and collections these are probably the most important features to learn in vba!
For j = 1 To UBound(arr) 'traverse source, ubound allows to find the "lastrow" of the array
If Not dict.Exists(arr(j, 1)) Then 'Check if value to lookup already exists in dictionary
dict.Add Key:=arr(j, 1), Item:=arr(j, 1) 'set key if I don't have it yet in dictionary
End If
Next j 'go to next row. in this simple example we don't travers multiple columns so we don't need a second counter (i)
'Before I can add values to a variant array I need to redim it. arr3 is a temp array to store matching col
'1 To UBound(arr2) = the number of rows, as in this example we'll add the match as a col we just keep the existing nr of rows
'1 to 1 => I just want to add 1 column but you can basically retrieve as much cols as you want
ReDim arr3(1 To UBound(arr2), 1 To 1)
For j = 1 To UBound(arr2) 'now that we have all values to match in our dictionary, we traverse the second source
If dict.Exists(arr2(j, 1)) Then 'matching happens here, for each value in col 1 we check if it exists in the dictionary
arr3(j, 1) = arr(j, 2) 'If a match is found, we add the value to find back, in this example col. 2, and add it to our temp array (arr3).
'arr3(j, 2) = arr(j, 3) 'As explained above, we could retrieve as many columns as we want, if you only have a few you would add them manually like in this example but if you have many we could even add an additional counter (i) to do this.
End If
Next j 'go to the next row
'''''''''''''''''
'Write to sheet only at the end, you could add formatting here
'''''''''''''''''
With Sheet2 'sheet on which I want to write the matching result
'UBound(arr2, 2) => ubound (arr2) was the lastrow, the ubound of the second dimension of my array is the lastcolumn
'.Cells(1, UBound(arr2, 2) + 1) = The startcel => row = 1, col = nr of existing cols + 1
'.Cells(UBound(arr2), UBound(arr2, 2) + 1)) = The lastcel => row = number of existing rows, col = nr of existing cols + 1
.Range(.Cells(1, UBound(arr2, 2) + 1), .Cells(UBound(arr2), UBound(arr2, 2) + 1)).Value2 = arr3 'write target array to sheet
End With
End Sub
Edit: This question has been re-worked to provide better clarity of my problem.
There's 2 factors to my question.
First Factor: I have a validation list in a sheet called "Admin Sheet". In that list are 'Tasks'.
I would like to cross reference those tasks in the "list", against those contained in a range (rangeString) taken from another sheet and count the number of 'Occurrences' for each item.
i.e. Task 1 appears 3 times, Task 2 appears 1 time, etc etc..
Factor 2: For each item within the list I would also like to gather the number of 'Hours' spent on that task.
For example:
Task 1 may appear 3 times on 3 different rows within the range. On each row in another column are the hours spent on that particular task. I would like to 'Sum' those hours from the 3 rows and I'd like to do this for all the 'Tasks'.
Note: The range is variable and will change daily.
Note: The columns that contain the info are: 'F' - Tasks and 'K' for Hours.
My current attempt at just capturing 'one' Task and its Hours associated with it:
Dim PaintWWArray() As Variant
Dim PHoursCnt As Long
Set srchRng = ActiveSheet.Range(rangeString)
Set rngfindValue = srchRng.find(what:="AD PAINTING W/W", Lookat:=xlPart)
'Find all the Tasks and Hours
If Not rngfindValue Is Nothing Then
rngFirstAddress = rngfindValue.Address
Do
PaintWWCnt = PaintWWCnt + 1
PHoursCnt = rngfindValue.Offset(0, 4).Value
ReDim Preserve PaintWWArray(PHoursCnt)
PaintWWArray(PHoursCnt) = PHoursCnt
Set rngfindValue = srchRng.FindNext(rngfindValue)
Loop Until rngfindValue Is Nothing Or rngfindValue.Address = rngFirstAddress
PWWSum = Application.WorksheetFunction.Sum(PaintWWArray)
MsgBox PWWSum
End If
Once I have collected the number of 'Occurrences' for each Task and the Sum of the hours for each task, I want to pass them into another sheet.
Worksheets("Weekly Data").Range("C6").Value = PaintWWCnt
Worksheets("Weekly Data").Range("D6").Value = PWWSum
I hope this is clearer...
I would suggest using a Dictionary.
Assuming you want to count all words:
Dim myDict
Set myDict = CreateObject("Scripting.Dictionary")
' Go through the array
For Each addDuty In arr
' If you only want to count specific words, add in IF statement here
myDict(addDuty) = myDict(addDuty) + 1
Next addDuty
If you only want to count words in an exiting set, it becomes slightly more elaborate.
It's not entirely clear what you want to achieve but the code below should give you the data you need. It's very fast. Please try it.
Private Sub STO_Answer()
' 024
' this procedure requires a reference to be set to
' Microsoft Scripting Runtime
Dim Counter As Scripting.Dictionary ' store task names and their count
Dim Arr As Variant ' an array of the data in Rng
Dim CellVal As Variant ' temporary storage of each cell value
Dim R As Long ' row counter
Dim Key As Variant ' a dictionary Key
Arr = ActiveSheet.Range("C2:D27").Value ' change to name the sheet
' adjust the range to suit
Set Counter = New Scripting.Dictionary
With Counter
For R = 1 To UBound(Arr) ' loop through all rows
AddToCounter Arr(R, 1), Counter ' first column of cell range
AddToCounter Arr(R, 2), Counter ' second column of cell range
Next R
For Each Key In Counter.Keys
Debug.Print Key, Counter.Item(Key)
Next Key
End With
End Sub
Private Sub AddToCounter(CellVal As Variant, _
Counter As Scripting.Dictionary)
' 024
With Counter
If .Exists(CellVal) Then
.Item(CellVal) = .Item(CellVal) + 1
Else
.Add CellVal, 1
End If
End With
End Sub
A Dictionary is a data structure which holds two related values. Here it's used to hold the task name and the number of times it occurs. Make sure you enable the reference to Microsoft Scripting Runtime in Tools > References. You don't specify if there is any relationship- between the tasks in the first column and the second. The above code counts both independently for now.
The result is printed to the Immediate Window. Of course, you might use this result in any other way in your code. Your question doesn't cover your intentions.
You won't be able to escape from the necessity to present your count in some way forever. As it turns out, there is only one efficient way to do it. This one:-
All duties are in column A and all added duties are in row 2.
Of course, you might use rather elaborate VBA to do the counting but Excel has a better way using a worksheet function. In order to set up COUNTIF() to work I created two named ranges as follows.
["Duties"] =OFFSET(Sheet2!$C$2,0,0,COUNTA(Sheet2!$C:$C)-1)
and
["AddDuties"] =OFFSET(Duties,0,1)
Sheet2!$C$2 is where my data started. Replace with the first cell of the first column of your data range. COUNTA(Sheet2!$C:$C)-1 makes this range dynamic. The function counts how many entries there are in that same column, -1 because the count would include a caption (modify if you have more or fewer headers).
AddDuties is simply defined as "same as Duties" but removed by one column to the right. You could move it elsewhere. As you add or delete rows in the column of Duties, AddDuties expands or contracts right along.
Now the formula in B3 is shown below. It's copied down and across as required. Please observe the $ signs.
[B3] =COUNTIFS(Duties,$A3,AddDuties,B$2)
This will probably generate a lot of zeroes. It did in my example and I didn't like them. Therefore I formatted B3 with the Custom cell format 0;; before copying to the other cells, which hides them.
Now this list would automatically update as you make entries in your data. You will never have to run code and the list will always be ready.
Finally, one recommendation. All your added duties, like "AD PAINITNG H/R", are hard to type correctly. Therefore the user should select them from a validation drop-down when entering them in the data. Most probably, you already have a list somewhere which feeds such drop-downs. The captions in the count list must be taken from the same source. But that creates redundancy. The better way is to make the list in B2:H2 of the count list the "original". Name the range and make it dynamic and you will never have to think about this subject again.
i think a better approach would be to use for each loops, this way you won't have to hardcode the conditions via IfElse. If you have the values in column A of a sheet and wants to go through those values and get their adjacent value in column B, you can use For Each looping to go through each values defined in A to get B.
just to add, regarding on counting of occurrence, you can define a counter that would add up for each occurrence of a unique value in column A.
I do not have time to wait for clarifications I asked... I prepared a piece of code, starting from the assumption that your strings to be counted are in column "F:F", and the value to be calculated is in column "K:K". The processing result is dropped on the last available column of the active pages, starting from row 2. If you prefer some relevant headers for the two involved columns, this can be easily automated. I used "Tasks and "Time...
It is able to deal with as many 'task' strings you will have in the future.
I commented the code lines, where I thought you do not understand what they do:
Sub CountOccurrencesAndValues()
Dim sh As Worksheet, rngF As Range, arrOcc As Variant, lastRow As Long, lastCol As Long
Dim arr As Variant, arrFin As Variant, countI As Long, valH As Double, j As Long, k As Long, i As Long
Set sh = ActiveSheet
lastRow = sh.Range("F" & Rows.count).End(xlUp).Row
lastCol = sh.UsedRange.Columns.count + 1
Set rngF = sh.Range("F2:F" & lastRow) 'the range where from to extract the unique values
arr = sh.Range("F2:K" & lastRow) 'the array to be processed
'Extract the unique values. Use for that a not used column:
rngF.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=sh.Cells(1, lastCol), Unique:=True
'Put the unique values (sttrings) in an array:
arrOcc = sh.Range(sh.Cells(1, lastCol), sh.Cells(sh.Cells(Rows.count, lastCol).End(xlUp).Row, lastCol)).value
'Clear the temporary used array:
sh.Range(sh.Cells(1, lastCol), sh.Cells(sh.Cells(Rows.count, lastCol).End(xlUp).Row, lastCol)).Clear
ReDim arrFin(1 To UBound(arrOcc, 1), 1 To 3)
k = 1
'Processing the range by iteration:
For i = 1 To UBound(arrOcc, 1)
For j = 1 To UBound(arr, 1)
If arr(j, 1) = arrOcc(i, 1) Then
'count the occurrences and the value
countI = countI + 1: valH = valH + arr(j, 6)
End If
Next j
'put the data in the final array
arrFin(k, 1) = arrOcc(i, 1): arrFin(k, 2) = countI: arrFin(k, 3) = valH
countI = 0: valH = 0: k = k + 1
Next i
'Drop the data from array in the last available column:
'sh.Cells(1, lastCol).value = "Tasks": sh.Cells(1, lastCol + 1).value = "Count": sh.Cells(1, lastCol + 2).value = "Time"
'sh.Cells(2, lastCol).Resize(UBound(arrFin, 1), UBound(arrFin, 2)).value = arrFin
Dim ws As Worksheet
Set ws = Worksheets("Weekly Data")
'Drop the data from array in "Weekly Data" worksheet:
ws.Range("C6").value = "Tasks": ws.Range("D6").value = "Count": ws.Range("E6").value = "Time"
ws.Range("C7").Resize(UBound(arrFin, 1), UBound(arrFin, 2)).value = arrFin
End Sub
I apologize, this is my first crack at Excel VBA so excuse my lack of knowledge!
So I have a list of (currently) 3 names to assign to the days in column A in a repeating order in Excel.
Currently my VBA code allows it to populate the selected cells with the names in a repeating pattern (this part is good), however there are two pieces I need help with.
1- with current code, once it reaches the bottom of the names it checks for the blank box that would end that list and starts over at the tops as directed but it puts a blank cell first (see screenshot). How can I have it put next name without adding blank cell first?
2- I want to be able to (once this gets going)select the entire D column through what dates need to be filled and:
-check the lowest non blank box
-match to list and set the
counter to name below that so
it continues the name order
from the last person who was
assigned
This is code I have now:
Sub EXAMPLE()
Dim count As Integer
count = 0
For Each c In Selection
c.Value = Range("X1").Offset(count, 0).Value
If c.Value = "" Then count = -1 And c.Value = Range("x1").Offset(count, 0).Value
count = count + 1
Next c
End Sub
Sorry I know that was long, I hope this makes sense.
I think it's worth reading about arrays, as this task is ideally suited to their use. Your best bet would be to read the names into an array and then build a recurring array whose dimension is equal to the number of rows in your dates column (or selection, or however you want to define the size of the output range).
Code would look a little like this:
Dim v As Variant
Dim people() As Variant, output() As Variant
Dim rowCount As Long, i As Long, j As Long
Dim endRange As Range
'Read the list of names into an array.
'This just takes all data in column "X" -> amend as desired
With Sheet1
Set endRange = .Cells(.Rows.Count, "X").End(xlUp)
v = .Range(.Cells(1, "X"), endRange).Value
End With
'Sense check on the names data.
If IsEmpty(v) Then
MsgBox "No names in Column ""X"""
Exit Sub
End If
If Not IsArray(v) Then
ReDim people(1 To 1, 1 To 1)
people(1, 1) = v
Else
people = v
End If
'Acquire the number of rows for repeating list of names.
'This just takes all data in column "A" -> amend as desired
With Sheet1
Set endRange = .Cells(.Rows.Count, "A").End(xlUp)
rowCount = .Range(.Cells(3, "A"), endRange).Rows.Count
End With
'Sense check date data.
If endRange.Row < 3 Then
MsgBox "No dates in Column ""A"""
Exit Sub
End If
'Make a recurring array.
ReDim output(1 To rowCount, 1 To 1)
i = 1
Do While i <= rowCount
For j = 1 To UBound(people, 1)
output(i, 1) = people(j, 1)
i = i + 1
If i > rowCount Then Exit Do
Next
Loop
'Write the output to column "D"
Sheet1.Range("D3").Resize(UBound(output, 1)).Value = output
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