I have some excel data which are now in rows and I want to get them into columns in an easy an effective way and I am not able to figure out how to do it. Any advice will be welcome! Thanks.
Example: turn sth like this in Excel
Team A
John
Team B
Peter
John
Team C
John
Peter
Oliver
Anna
Team D
Anna
into:
Team A John
Team B Peter John
Team C John Peter Oliver Anna
Team D Anna
I'm guessing your real data is much longer than this list so here is what i would do in that case.
First, put the list in column B and add a formula that copies the Team down column A:
*note you have to copy and paste the value from b2 into a2 and start the formula on a3.
Type the formula =IF(LEFT(B3,4)="Team",B3,A2) in cell a3 and drag it down (or control shift down then control d to fill down). What is this formula doing? It looks at the B cell, if it starts with "Team" it uses the value of that cell, otherwise it uses the value of the cell above (which will be another "Team").
Then, copy and paste and values column A so you don't loose the formula results after the next steps:
Filter column B "player" on the search term "team" and delete those entire rows:
Now you have column A of teams, Column B of players and use this formula in column C: =IF(A2=A1,CONCATENATE(C1," ",B2),CONCATENATE(A2," ",B2)).
This formula looks at the Team column and if it differs, it start a new chain of team and player otherwise it adds the player to the chain above of team and player.
I hope you can follow the logic here and accomplish what you are trying to do. Let me know how it goes.
Column to Vertical List
Option Explicit
'*******************************************************************************
' Purpose: Processes a one-column range containing groups of title-values data,
' transposing the titles to the first column of a range and the values
' to columns next to the title thus creating a vertical list.
'*******************************************************************************
Sub ColumnToVerticalList()
Const cStrSheet As String = "Sheet1" ' Worksheet Name
Const cLngFirstRow As Long = 2 ' First Row of Source Data
Const cStrColumn As String = "A" ' Column of Source Data
Const cStrSearch As String = "Team" ' Search String
Const cStrCell As String = "C2" ' Target Cell
Dim arrSource As Variant ' Source Array
Dim lngArr As Long ' Source Array Row Counter
Dim arrTarget As Variant ' Target Array
Dim lngRows As Long ' Number of Rows (Counter) in Target Array
Dim iCols As Integer ' Number of Columns (Counter) in Target Array
Dim iColsTemp As Integer ' Target Array Columns Counter
Dim strTargetRange As String ' Target Range
' Paste the calculated source range into the source array - arrSource.
With ThisWorkbook.Worksheets(cStrSheet)
arrSource = .Range( _
.Cells(cLngFirstRow, cStrColumn), _
.Cells(.Cells(Rows.Count, cStrColumn).End(xlUp).Row, cStrColumn))
End With
' Calculate the number of rows and columns of the target array - arrTarget.
iColsTemp = 1
For lngArr = LBound(arrSource) To UBound(arrSource)
If InStr(1, arrSource(lngArr, 1), cStrSearch, vbTextCompare) <> 0 Then
If iColsTemp > iCols Then
iCols = iColsTemp
End If
iColsTemp = 1
Debug.Print arrSource(lngArr, 1)
lngRows = lngRows + 1
Else
iColsTemp = iColsTemp + 1
End If
Next
' Calculate the target range address.
strTargetRange = Range(Cells(Range(cStrCell).Row, Range(cStrCell).Column), _
Cells(Range(cStrCell).Row + lngRows - 1, _
Range(cStrCell).Column + iCols - 1)).Address
' Resize the target array.
ReDim arrTarget(1 To lngRows, 1 To iCols)
' Write data from source array to target array.
lngRows = 0
iCols = 1
For lngArr = LBound(arrSource) To UBound(arrSource)
If InStr(1, arrSource(lngArr, 1), cStrSearch, vbTextCompare) <> 0 Then
iCols = 1
lngRows = lngRows + 1
arrTarget(lngRows, 1) = arrSource(lngArr, 1)
Else
iCols = iCols + 1
arrTarget(lngRows, iCols) = arrSource(lngArr, 1)
End If
Next
' Paste data of the target array into the target range
ThisWorkbook.Worksheets(cStrSheet).Range(strTargetRange) = arrTarget
End Sub
Related
I have an Excel table which may contain such:
Screenshot of content from a table, columns C and D
It may be much longer
on top of column D may be an empty cell, but after that it is always the same sequence of contents repeating.
I want to copy and paste in another sheet, with transpose, the contents of the neighboring cells, that is in C, so it would look like:
a screenshot from destination table
It is easy to copy the header, but I am completely unable to have the code loop through and copy all the column C contents that appear left to what is between 1tst and 27tst in the original column D, until all of the blocks of data are copied.
To complicate things even further, I want all empty cells in this destination table to take the value from the cell above, basically filling the blanks that way. This would then look like
Final look of the destination table
In this example, the Words "Algeria | DZ" have to be automatically copied down. The cell under "24tst" remains blank as there is nothing but the header preceding this row.
I have absolutely no starting code here, as these data already made a long process from a Word file through a csv using Ruby, and then the csv is read in and reformatted into various sheets in the Excel file with already long line sof code. That all works so far, but these are my missing steps.
Any help is greatly appreciated. I only started coding again 3 weeks ago, after having never programmed in VBA but years ago in perl and R.
-- In response to VBasic2008 and to try that out I made now a test spreadsheet that looks this way:this is closer to what it really looks like
I changed the constants here:
enter code hereConst sName As String = "Tabelle1" ' Source Worksheet Name
enter code hereConst sFirst As String = "C2" ' Source First Cell Address
enter code hereConst tName As String = "Tabelle2" ' Target Worksheet Name
enter code hereConst tFirst As String = "B1" ' Target First Cell Address
The groups will actually be constant in length, actually more than 11, but that can be fixed later.
These:
1tst
2tst
3tst
11tst
4tst
22tst
23tst
24tst
25tst
26tst
27tst -
I pasted this already into target sheet.
What I get from my test using my thus modified solution from VBasic2008 is this:
Afghanistan | AF Åland Islands | AX Albania | AL Algeria | DZ American Samoa | AS Belgium | BE Belize | BZ 24tst Bermuda | BM Bhutan | BT Bolivia | BO
Bonaire, Sint Eustatius and Saba | BQ Bosnia and Herzegovina | BA Botswana | BW Algeria | DZ Brazil | BR Christmas Island | CX Cocos (Keeling) Islands | CC Colombia | CO Comoros | KM n/a Congo | CD
This is almost perfect, except for it should not, in the first row in the target sheet after the headers, copied down the "24tst". Can this still be tweaked?
A Copy Transpose
This will work correctly only if the data is consistent i.e. 11 rows of data and 1 empty (Next-Group) row (can be changed in the constants section) i.e. if you have 5 data sets, there has to be 60 rows of data. If there is 65, only 60 will be processed and if there is 59, only 48 will be processed.
The following image shows what the current setup in the code will produce (without the formatting).
The Code
Option Explicit
Sub transposeData()
Const sName As String = "Sheet1" ' Source Worksheet Name
Const sFirst As String = "A2" ' Source First Cell Address
Const tName As String = "Sheet1" ' Target Worksheet Name
Const tFirst As String = "D1" ' Target First Cell Address
Const NoE As Long = 11 ' Number of Elements
Const NoER As Long = 1 ' Number of Empty Rows
Dim wb As Workbook
Set wb = ThisWorkbook ' The workbook containing this code.
' Define Source Worksheet ('ws').
Dim ws As Worksheet
Set ws = wb.Worksheets(sName)
' Define Source First Cell ('First').
Dim First As Range
Set First = ws.Range(sFirst)
' Define Source Last Cell ('Last').
Dim Last As Range
Set Last = First.Offset(ws.Rows.Count - First.Row, 1).End(xlUp)
If Last.Row - First.Row + 1 < NoE Then
GoTo ProcExit
End If
' Define Source Range ('rng').
Dim rng As Range
Set rng = ws.Range(First, Last)
' Write values from Source Range to Source Array ('Source').
Dim Source As Variant
Source = rng.Value
' Define number of Data Sets ('NoDS').
Dim NoDS As Long
NoDS = Int(UBound(Source, 1) / (NoE + NoER))
' Define Target Number of Rows ('NoR').
Dim NoR As Long
NoR = NoDS + 1
' Define Target Array ('Target').
Dim Target As Variant
ReDim Target(1 To NoR, 1 To NoE)
' Declare additional variables for the upcoming loops.
Dim CurrentValue As Variant ' Source Current Value
Dim CurrentLR As Long ' Source Current Last Row
Dim j As Long ' Target Columns Counter
Dim i As Long ' Target Rows Counter
' Write headers.
For j = 1 To NoE
Target(1, j) = Source(j, 2)
Next j
' Write data.
For i = 2 To NoR
CurrentLR = (i - 2) * (NoE + NoER)
For j = 1 To NoE
CurrentValue = Source(CurrentLR + j, 1)
If Not IsEmpty(CurrentValue) Then
Target(i, j) = CurrentValue
Else
Target(i, j) = Target(i - 1, j)
End If
Next j
Next i
' Define Target Worksheet ('ws').
Set ws = wb.Worksheets(tName)
' Define Target First Cell ('First').
Set First = ws.Range(tFirst)
' Define Target Range ('rng').
Set rng = First.Resize(NoR, NoE)
' Write values from Target Array to Target Range.
rng.Value = Target
' Inform user
MsgBox "Data transferred.", vbInformation, "Success"
ProcExit:
End Sub
EDIT
Tiny Change
Instead of Target(i, j) = Target(i - 1, j) use
If i > 2 Then
Target(i, j) = Target(i - 1, j)
End If
I think the easiest way of doing this is looping through cells with headers and checking each value.
When you find your "next-group" cell then trigger some ifs;
Example program which covers your problem below:
Sub solution()
'Set first row
Dim firstrow As Integer
firstrow = 1
'Find last row
Dim lastrow As Integer
lastrow = Cells(Rows.Count, 1).End(xlUp).Row 'Go to bottom of file and jump up to last non-empty cell
'Set first column
Dim firstcolumn As Integer
firstcolumn = 1
'find last column
Dim lastcolumn As Integer
lastcolumn = 2
'Set first cell of target table
Dim targetrange As Range
Set targetrange = Range("E2")
Dim i As Integer
Dim cnt As Integer 'conuter for creating offset (for columns)
Dim cnt2 As Integer 'conuter for creating offset (for rows)
'Copy headers
cnt = 0
For i = firstrow To lastrow
If Cells(i, lastcolumn).Value = "next-group" Then Exit For
Cells(i, lastcolumn).Copy targetrange.Offset(0, cnt)
cnt = cnt + 1
Next i
'Copy data
cnt = 0
cnt2 = 1
For i = firstrow To lastrow
'If we have text "next group"
If Cells(i, lastcolumn).Value = "next-group" Then
cnt = 0 'start with first column
cnt2 = cnt2 + 1 'Start with next row
'This cell is not copied
Else
'cell is copied
Cells(i, firstcolumn).Copy targetrange.Offset(cnt2, cnt)
'column counter is increased
cnt = cnt + 1
End If
Next i
'Change blank cells in current region into formula which points to cell one row above
'targetrange.CurrentRegion.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
'Same formula but keep cells in first row of data blank istead copying header
Dim targetArea As Range
Set targetArea = targetrange.CurrentRegion
targetArea.Offset(2).Resize(targetArea.Rows.Count - 2).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
End Sub
I didn't cover case when you have empty cell in first row as you didn't described what you're expecting (at this moment it have same formula so it will be filled with header value).
UPDATE: I didnt put "=" inside R1C1 formula, now its fixed.
UPDATE2: Changed part of filling empty cells so it skips first 2 rows (Headers and first row of data) instead filling it as mentioned in question update
Example data set
A B c D E F G H I J K L M N O P
-10 5 16 23 8 2 6 3162625 -10 5 16 23 8 2 6 3162626
Desired output
A B C D E F G H I J K L M N O P
-10 5 16 23 8 2 6 3162625
-10 5 16 23 8 2 6 3162626
Constant is -10 and i need the 7 columns after it
using VBA I can transfer column A to H to another sheet, but i can't get the VBA to move to Column I, Q etc etc
The VBA I have is
Sub search_and_extract_singlecriteria()
'1.
'2.
'3.
Dim datasheet As Worksheet
Dim reportsheet As Worksheet
Dim recordid As String
Dim finalrow As Integer
Dim i As Integer
Set datasheet = Sheet1
Set reportsheet = Sheet2
recordid = "-46" 'reportsheet.Range("B2").Value
'reportsheet.Range("A1:L100").ClearContents
datasheet.Select
finalrow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To finalrow
If Cells(i, 1) = recordid Then
Range(Cells(i, 9), Cells(i, 17)).Copy
reportsheet.Select
Range("A200").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
datasheet.Select
End If
Next i
reportsheet.Select
Range("B2").Select
End Sub
Simple copy and paste is not an option as on one row, the 8 column sets repeat over a 1000 columns. each row, has varying column lengths. i will end up with 300k plus rows across 8 columns A:H if this can be done
Any suggestions would be greatly appreciated.
Try this. Have added some comments to explain.
If it's slow, more efficient to use arrays.
Sub x()
Dim r As Range
application.screenupdating=false
Set r = Sheet1.Range("A1").Resize(, 8) 'set starting range 1 x 8
Do Until IsEmpty(r(1)) 'keep doing this until first cell is empty
r.Copy Sheet2.Range("A" & Rows.Count).End(xlUp)(2) 'copy to first blank cell in A sheet2
Set r = r.Offset(, 8) 'move copy range along by 8 cells to the right
Loop
application.screenupdating=true
End Sub
Array vs Range
Option Explicit
'START ****************************************************************** START'
' Title: Search and Extract Single Criteria '
' Purpose: In a specified Data Worksheet, each non-empty row contains '
' an unknown number of consecutive data sets of a specified '
' size (columns). '
' By looping through each row of Data Worksheet, copies each '
' data set to another specified Report Worksheet one below '
' another, starting from a specified cell range. '
'******************************************************************************'
Sub search_and_extract_singlecriteria()
' 10s for 1280 cols and 3000 rows = 480000 rows in Report Sheet
Const Noc As Long = 8 ' Size of Data Set (Number of Columns)
' = Number of Columns in Report Array
Const strRR As String = "B2" ' Report First Cell Range Address
Dim wsD As Worksheet: Set wsD = Sheet1 ' Data Sheet
Dim wsR As Worksheet: Set wsR = Sheet2 ' Report Sheet
Dim rng As Range ' Last Non-Empty Cell in the Last Non-Empty Row,
' Non-Empty Range (both in Data Sheet)
Dim vntD As Variant ' Data Array (2D 1-based)
Dim vntC As Variant ' Count Array (1D 1-based)
Dim vntR As Variant ' Report Array (2D 1-based)
Dim Nor As Long ' Number of Data Sets
' = Number of Rows in Report Array
Dim i As Long ' Data/Count Array Rows Counter
Dim j As Long ' Data Array Columns Counter
Dim k As Long ' Count Array Values Counter
Dim m As Long ' Report Array Rows Counter
' IN DATA SHEET
' Note: It is assumed that Data Sheet contains ONLY Data Sets.
' By defining the Last Non-Empty Cell in the Last Non-Empty Row
' using the Find method, check if the sheet is not empty.
Set rng = wsD.Cells.Find("*", wsD.Cells(wsD.Rows.Count, wsD.Columns.Count), _
xlFormulas, , xlByRows)
If rng Is Nothing Then Exit Sub
' Define Non-Empty Range on Data Sheet.
Set rng = wsD.Range(wsD.Cells(rng.Row, wsD.Cells.Find("*", _
wsD.Cells(wsD.Rows.Count, wsD.Columns.Count), , , xlByColumns).Column), _
wsD.Cells(wsD.Cells.Find("*", , , , xlByRows, xlPrevious).Row, _
wsD.Cells.Find("*", , , , xlByColumns, xlPrevious).Column))
' Write values of Non-Empty Range on Data Sheet to Data Array.
vntD = rng
' Release object variables. Necessary data is in Data Array (vntD).
Set rng = Nothing
Set wsD = Nothing
' IN ARRAYS
' Task: Calculate Number of Rows in Report Array and populate Count Array.
' Resize Count Array (vntC) to number of rows of Data Array (vntD).
ReDim vntC(1 To UBound(vntD))
' Loop through rows (1st dimension) of Data Array (vntD).
For i = 1 To UBound(vntD)
' Loop through every Noc-th column (2nd dimension) of Data Array (vntD).
For j = 1 To UBound(vntD, 2) Step Noc
' Check if value of current element in Data Array (vntD) is <> "".
If vntD(i, j) <> "" Then
' Value of current element in Data Array (vntD) is <> "".
' Increase Count Array Value (Count of Data Sets in current row
' of Data Array).
k = k + 1
' Increase Number of Rows in Report Array
' (Total Count of Data Sets).
Nor = Nor + 1
Else
' Value of current element in Data Array (vntD) is = "".
' The following will leave the current element in Count Array
' empty, i.e. 0 which becomes obvious only later in:
' "If vntC(i) > 0 Then...".
Exit For
End If
Next
' Write current Count Array Value (k) to current element
' of Count Array (vntC).
' Note: The i-th row in Data Array contains k Data Sets.
vntC(i) = k
' Reset Count Array Values Counter.
k = 0
Next
' Remarks: Count Array (vntC) has the same number of elemnts
' as Data Array (vntD) has rows. Each value in Count Array (vntC)
' respresents the number of Data Sets per row of Data Array (vntD).
' The implementation of Count Array (vntC) makes it possible
' to write the last loop as a For Next loop:
' "For j = (k - 1) * Noc + 1 To (k - 1) * Noc + Noc...",
' without checking if there are "" values, because it has
' already been checked previously in:
' "If vntD(i, j) <> "" Then)...".
' Task: Define and populate Report Array.
' Resize Report Array (vntR) to rows defined by Number of Data Sets (Nor)
' and columns specified by (Column) Size of Data Set (Noc).
ReDim vntR(1 To Nor, 1 To Noc)
' Loop through rows (1st dimension) of Data Array (vntD).
For i = 1 To UBound(vntD)
' Check if the value in the same row (i) in Count Array (vntC) is > 0.
If vntC(i) > 0 Then
' Value in the same row (i) in Count Array (vntC) is > 0.
' Loop through Data Sets from Data Array.
For k = 1 To vntC(i)
' Increase Report Array Rows Counter (m).
m = m + 1
' Loop through columns (j) of current Data Set.
For j = (k - 1) * Noc + 1 To (k - 1) * Noc + Noc
' Write value of current element of Data Array (Set) to
' current element of Report Array.
vntR(m, j - (k - 1) * Noc) = vntD(i, j)
Next
Next
'Else
' Value in the same row (i) in Count Array (vntC) is NOT > 0 i.e.
' skipping (No Data Set in) current row of Data Array (vntD).
End If
Next
' IN REPORT SHEET
' Copy values of Report Array to Report Range defined by the specified
' Report First Cell Range Address (strRR) in specified Report Sheet (wsR)
' and the size (rows and columns) of Report Array (vntR).
wsR.Range(strRR).Resize(UBound(vntR), UBound(vntR, 2)) = vntR
End Sub
'END ********************************************************************** END'
I have a problem I need help with involving Excel and VBA. I know next to nothing about Excel/VBA, and I need a coding solution to help me avoid performing the extremely tedious task of doing this manually (think hundreds of lines that need to be parsed where one row could become multiple rows in a new sheet). I've been searching the web for solutions, but I just keep getting confused by the answers (because I don't know anything about VB and using it to program a macro in Excel), so I figured I'd seek help for my specific problem.
Here is the rundown: I have a spreadsheet where I need to copy rows from a source sheet to a target sheet. The source sheet has 2 columns (A & B) that can be thought of as a key/value pair where col A contains the key and col B contains the value. The problem lies with the values in col B. The values can either be a single line of text or a numbered list of different texts
What I want to do is for each row in the source:
split the values in col B to get an array of each individual value (if the value is in the form of a numbered list)
create new rows in the target sheet by looping over the split array of values such that a new row will be created where:
new row col A = source row col A key and new row col B = current iteration index from the array of split values.
if no numbered list, just copy the source row into target sheet
Source
A B
key1 1. text1
2. text2
key2 1. text3
Target
A B
key1 text1
key1 text2
key2 text3
The numbered list in a cell will be multiple lines where each line of text is prepended by a decimal and a dot. This applies to single line cells as well.
(Update) Bear in mind that the values in either col A or B are not simple text values. These are full on sentences. So, I'm not sure a simple formula is going to work.
Split Multi Line
It is unclear which line separator occurs in the multi line cells. Choose one, vbLf worked for me.
Adjust the values in the constants section to fit your needs.
The Code
Sub SplitMultiLine()
Const cSheet1 As Variant = "Sheet1" ' Source Worksheet Name/Index
Const cFirstR As Integer = 1 ' Source First Row Number
Const cFirstC As Variant = "A" ' Source First Column Letter/Number
Const cLastC As Variant = "C" ' Source Last Column Letter/Number
Const cMulti As Integer = 2 ' Multi Column
Const cSplit As String = vbLf ' Split Char(vbLf, vbCrLf, vbCr)
Const cDot As String = "." ' Dot Char (Delimiter)
Const cSheet2 As Variant = "Sheet1" ' Target Worksheet Name/Index
Const cTarget As String = "E1" ' Target First Cell Address
Dim vntS As Variant ' Source Array
Dim vntSplit As Variant ' Split Array
Dim vntT As Variant ' Target Array
Dim lastR As Long ' Source Last Row
Dim i As Long ' Source Array Row Counter
Dim j As Integer ' Source/Target Array Column Counter
Dim k As Long ' Target Array Row Counter
Dim m As Integer ' Split Array Row Counter
' Paste Source Range into Source Array.
With Worksheets(cSheet1)
lastR = .Cells(.Rows.Count, cFirstC).End(xlUp).Row
vntS = .Range(.Cells(cFirstR, cFirstC), .Cells(lastR, cLastC))
End With
' Count the number of rows in target array.
For i = 1 To UBound(vntS)
k = k + UBound(Split(vntS(i, cMulti), cSplit)) + 1
Next
' Write from Source to Target Array.
ReDim vntT(1 To k, 1 To UBound(vntS, 2))
k = 0
For i = 1 To UBound(vntS)
k = k + 1
vntSplit = Split(vntS(i, cMulti), cSplit)
For m = 0 To UBound(vntSplit)
If InStr(vntSplit(m), cDot) > 0 Then
vntT(k, cMulti) = Trim(Right(vntSplit(m), Len(vntSplit(m)) _
- InStr(vntSplit(m), cDot)))
Else
vntT(k, cMulti) = vntSplit(m)
End If
For j = 1 To UBound(vntS, 2)
If j <> cMulti Then
vntT(k, j) = vntS(i, j)
End If
Next
k = k + 1
Next
k = k - 1
Next
' Paste Target Array into Target Range calculated from Target Frist Cell.
With Worksheets(cSheet2).Range(cTarget)
.Resize(UBound(vntT), UBound(vntT, 2)) = vntT
End With
End Sub
An Over-Commenting
Sub SplitMultiLineOverCommented()
Const cSheet1 As Variant = "Sheet1" ' Source Worksheet Name/Index
Const cFirstR As Integer = 1 ' Source First Row Number
Const cFirstC As Variant = "A" ' Source First Column Letter/Number
Const cLastC As Variant = "C" ' Source Last Column Letter/Number
Const cMulti As Integer = 2 ' Multi Column
Const cSplit As String = vbLf ' Split Char(vbLf, vbCrLf, vbCr)
Const cDot As String = "." ' Dot Char (Delimiter)
Const cSheet2 As Variant = "Sheet1" ' Target Worksheet Name/Index
Const cTarget As String = "E1" ' Target First Cell Address
Dim vntS As Variant ' Source Array
Dim vntSplit As Variant ' Split Array
Dim vntT As Variant ' Target Array
Dim lastR As Long ' Source Last Row
Dim i As Long ' Source Array Row Counter
Dim j As Integer ' Source/Target Array Column Counter
Dim k As Long ' Target Array Row Counter
Dim m As Integer ' Split Array Row Counter
' Paste Source Range into Source Array.
With Worksheets(cSheet1)
' The last row of data is usually calculated going from the bottom up,
' it is like selecting the last cell and pressing CTRL UP and returning
' =ROW() in Excel.
lastR = .Cells(.Rows.Count, cFirstC).End(xlUp).Row
' Paste a range into an array actually means copying it. The array
' created is a 1-based 2-dimensional array which has the same number
' of rows and columns as the Source Range.
vntS = .Range(.Cells(cFirstR, cFirstC), .Cells(lastR, cLastC))
End With
' Count the number of rows in Target Array.
' You refer to the last row of the array with UBound(vntS) which is short
' for UBound(vntS, 1) which reveals that it is referring to the first
' dimension (rows).
For i = 1 To UBound(vntS)
' We are splitting the string by cSplit which is the line
' separator (delimiter). When you enter something into a cell and
' hold left Alt and press ENTER, the vbLf character is set in place
' of the line separator. But the data may have been imported from
' another system that uses another line separator. When splitting the
' string, a 0-based array is 'created' and its UBound is the last
' row, but since it is 0-based we have to add 1.
k = k + UBound(Split(vntS(i, cMulti), cSplit)) + 1
Next
' Write from Source to Target Array.
' After we have calculated the number of rows, we have to resize the
' Target Array. To avoid confusion, I always use '1 To' to be certain that
' it is a 1-based array. Since the number columns of the Source Array and
' the Target Array is the same, we use the UBound of the Source Array to
' resize the second dimension of the Target Array - UBound(vntS, 2) where
' 2 is indicating the second dimension, columns.
ReDim vntT(1 To k, 1 To UBound(vntS, 2))
' We will use again k as the row counter since its value is no more
' needed. This is what I have many times forgotten, so maybe it is
' better to use a different variable.
k = 0
' Loop through the columns of Source Array.
For i = 1 To UBound(vntS)
' Increase the row of Target Array or e.g. align it for writing.
k = k + 1
' Split the string (lines) in the Multi Column into the 0-based
' Split Array.
vntSplit = Split(vntS(i, cMulti), cSplit)
' Loop through the values of the Split Array
For m = 0 To UBound(vntSplit)
' Check if value contains cDot. The Instr function returns 0 if
' a string has not been found, it's like =FIND(".",A1) in Excel,
' except that Excel would return an error if not found.
If InStr(vntSplit(m), cDot) > 0 Then
' If cDot was found then write the right part after cDot
' to the current row of column cMulti but trim the result
' (remove space before and after.
' It's like =TRIM(RIGHT(A1,LEN(A1)-FIND(".",A1))) in Excel.
vntT(k, cMulti) = Trim(Right(vntSplit(m), Len(vntSplit(m)) _
- InStr(vntSplit(m), cDot)))
Else
' If cDot was not found then just write the value to the
' current row.
vntT(k, cMulti) = vntSplit(m)
End If
' Loop through all columns.
For j = 1 To UBound(vntS, 2)
If j <> cMulti Then
' Write to other columns (Not cMulti)
vntT(k, j) = vntS(i, j)
End If
Next ' Next Source/Target Array Column
' Increase the current row of Target Array before going to next
' value in Split Array.
k = k + 1
Next ' Next Split Array Row
' Since we have increased the last current row but haven't written to
' it, we have to decrease one row because of the "k = k + 1" right below
' "For i = 1 To UBound(vntS)" which increases the row of Target Array
' for each next row in Source Array.
k = k - 1
Next ' Next Source Array Row
' Paste Target Array into Target Range calculated from Target Frist Cell.
' Like we pasted a range into an array, we can also paste an array into
' a range, but it has to be the same size as the array, so by using
' the Resize method we adjust the Target Range First Cell to the Target
' Range, using the last row and column of the Target Array. Again,
' remember UBound(vntT) is short for UBound(vntT, 1) (rows).
With Worksheets(cSheet2).Range(cTarget)
.Resize(UBound(vntT), UBound(vntT, 2)) = vntT
End With
End Sub
You can do this with two formulas.
I'm assuming your data is in Sheet1.
For the first columns, use the following formula:
=IF(ISBLANK(Sheet1!A2),A1,Sheet1!A2)
For the second one use:
=IFERROR(RIGHT(Sheet1!B2,LEN(Sheet1!B2)-FIND(". ",Sheet1!B2)-1),Sheet1!B2)
And populate down.
edit:
The first formula will look at the corresponding cell in Sheet1, column A. If it is blank, it will take the value of the cell above where the formula is. If it isn't blank, it will take the value of the cell in Sheet1, column A that it just checked.
The second formula looks for the string ". " in the cells in Sheet1 column B and removes it and everything to the left of it from the text. If the string in question (". ") is not found (meaning there is no numbering in that given cell) it would return an error, so the whole thing is wrapped in an IFERROR statement which returns the value of the cell in Sheet1 column B if it is triggered.
I'm currently using excel 2010 and have some data I'm trying to transform so to speak and output the results into sheet 2. I'm not sure where to start and was hoping for some guidance.
The image below is only a sample set of data. The actual spreadsheet consists of 92 rows and 78 columns. The first three columns are name and address and the rest are very similar to what is shown in the image. Some cells have a value, a zero, or blank. The rows in red is what I would like to accomplish.
Here is a solution using VBA.
It assumes that your existing sheet is named "Sheet1", and the new sheet exists and is named "Sheet2".
Option Explicit
Sub CollapseData()
Dim RowNbr As Long
Dim SrcColNbr As Long
Dim DestColNbr As Long
Dim MaxRowNbr As Long
Dim PeriodNbr As Long
Dim MaxPeriodNbr As Long
Dim SrcSheetName As String
Dim DestSheetName As String
Dim SrcSheet As Worksheet
Dim DestSheet As Worksheet
SrcSheetName = "Sheet1"
DestSheetName = "Sheet2"
Set SrcSheet = ThisWorkbook.Worksheets(SrcSheetName)
Set DestSheet = ThisWorkbook.Worksheets(DestSheetName)
' Determine last row number in use
MaxRowNbr = SrcSheet.Cells(Rows.Count, 1).End(xlUp).Row
' Copy name, addr1, and addr2 headings
For DestColNbr = 1 To 3
Call CopyCell(SrcSheet.Cells(1, DestColNbr), DestSheet.Cells(1, DestColNbr))
Next DestColNbr
' Determine number of period columns in use
MaxPeriodNbr = SrcSheet.Cells(1, Columns.Count).End(xlToLeft).Column - 3
' Generate date headings
DestColNbr = 4
For PeriodNbr = 1 To MaxPeriodNbr
DestSheet.Cells(1, DestColNbr) = "date" & Format(PeriodNbr, "##0")
DestSheet.Cells(1, DestColNbr + 1) = "amount" & Format(PeriodNbr, "##0")
DestColNbr = DestColNbr + 2
Next PeriodNbr
' Copy data from Sheet1 to Sheet2
For RowNbr = 2 To MaxRowNbr
' Copy name and address
For DestColNbr = 1 To 3
Call CopyCell(SrcSheet.Cells(RowNbr, DestColNbr), DestSheet.Cells(RowNbr, DestColNbr))
Next DestColNbr
DestColNbr = 4
For SrcColNbr = 4 To MaxPeriodNbr + 3
If SrcSheet.Cells(RowNbr, SrcColNbr) <> 0 Then
' Copy date from Sheet1 to Sheet2
Call CopyCell(SrcSheet.Cells(1, SrcColNbr), DestSheet.Cells(RowNbr, DestColNbr))
' Copy amount from Sheet1 to Sheet2
Call CopyCell(SrcSheet.Cells(RowNbr, SrcColNbr), DestSheet.Cells(RowNbr, DestColNbr + 1))
DestColNbr = DestColNbr + 2
End If
Next SrcColNbr
Next RowNbr
End Sub
Private Sub CopyCell(FromCell As Range, ToCell As Range)
FromCell.Copy
ToCell.PasteSpecial xlPasteValues
ToCell.PasteSpecial xlPasteFormats
End Sub
Here is how you can do it for the example you have shown. It should be simple to replicate the formulas for the whole set of data you have.
To get the first date that has an amount greater than zero, i am doing an array multiplication of the amounts array > 0 and the dates array. then i invert this array (1/array). AGGREGATE function gives you the largest value after ignoring the erros(#div0). Inverting again gives you the first date that has an amount greater than 0.
for the next date, i include one more criteria by checking if the date array has date greater than the date previously calculated, thus giving me the next date.
The formula for amounts are basically HLOOKUPs for the date that was retrieved.
for date 1
=1/AGGREGATE(14,6,1/((D2:I2>0)*D1:I1),1)
for amount 1
=HLOOKUP(D6,$D$1:$I$2,2,FALSE)
for date 2
=1/AGGREGATE(14,6,1/(($D$2:$I$2>0)*($D$1:$I$1>D6)*$D$1:$I$1),1)
for amount 2
=HLOOKUP(F6,$D$1:$I$2,2,FALSE)
for date 3
=1/AGGREGATE(14,6,1/(($D$2:$I$2>0)*($D$1:$I$1>F6)*$D$1:$I$1),1)
for amount 3
=HLOOKUP(H6,$D$1:$I$2,2,FALSE)
Please click on this link for the image of the excel sheet containing the data:
http://i.stack.imgur.com/Dl1YQ.gif
I have a list of task codes in column A.
During each task I will gain a certain competencies. Each competency listed in column C or E is gained during the tasks listed in columns D and F respectively.
Now I need a formula to tell me on column B (COMPETENCIES), which of the competencies are gained during each task of column A. For example for Task A2 (MSC) I expect to see "Tech1,Tech2,Tech3,Tech4,PS1,PS2,PS3" in column B (B2).
I suppose I should treat task codes in column A as strings that should be looked for in the cell contents of columns D and F and when found in any cell of those columns, the corresponding competency should be copied from the same row on the column to the left of the cell, into column B. And then all these entries should be separated by commas in each cell of column B (if there is more than one competency met during task A2).
Can you help me please?
Many Thanks,
Hamid
I agree with the comments: this is a task for VBA.
I typed your GIF into a worksheet. I have made no attempt to fix what I believe are errors. For example, Column A contains "SEMS" but column D contains "SMES".
Step 1 of the routine below is to work down columns C and D then columns E and F and accumulates the data in an array of structures. The objective is to reverse the relationships to give:
MSC Tech1 Tech2 ...
ATT Tech1 Tech2 ...
: :
The result is them placed in column B.
The first step is quite complicated. I hope I have included enough comments for you to understand my code. Work through it slowly and come back with questions is necessary.
Option Explicit
' VBA as intrinsic data types : string, long, double, etc.
' You can declare an array of longs, say.
' The size of an array can be fixed when it is declared:
' Dim A(1 To 5) As Long
' or it can be declared as dynamic and then resized as necessary:
' Dim A() As Long
' ReDim A(1 to 5) ' Initialise A with five entries
' ReDim Preserve A(1 to 10) ' Preserve the first five entries in A
' ' and add another 5.
'
' Sometimes a more complex structure is required. For this problem we need
' to build a list of Tasks with a list of Competencies against each Task.
' VBA allows us to to define the necessary structure as a "User Type"
' Define a user type consisting of a Task name and an array of Competencies
Type typTaskComp
Task As String
Comp() As String
End Type
' Declare array in which Tasks and Competencies are
' accumulated as a dynamic array of type typTaskComp.
Dim TaskComp() As typTaskComp
Dim InxTaskCrntMax As Long
Sub MatchTaskToCompetencies()
Dim CompListCrnt As String
Dim InxCompCrnt As Long ' Index for Competencies for a Task
Dim InxTaskCrnt As Long ' Index for Tasks
Dim RowCrnt As Long
Dim TaskCrnt As String
ReDim TaskComp(1 To 10) ' Initialise TaskComp for 10 Tasks
InxTaskCrntMax = 0 ' The last currently used row in TaskComp. That
' is, no rows are currently used.
' Load array TaskComp() from the sheet
Call DecodeCompencyTask("Sheet1", 3, 4)
Call DecodeCompencyTask("Sheet1", 5, 6)
' The format and contents of TaskComp is now:
' Competency ...
' Task 1 2 3 4 5 ...
' 1 MSC Tech1 Tech2 Tech3 Tech4 PS1
' 2 ATT Tech1 Tech2 Tech3 Tech4 PS1
' 3 PLCY Tech1 Tech2 Tech4 Tech5 Tech6
' : :
' Display contents of TaskComp() to Immediate window
For InxTaskCrnt = 1 To InxTaskCrntMax
Debug.Print Left(TaskComp(InxTaskCrnt).Task & Space(5), 6);
For InxCompCrnt = 1 To UBound(TaskComp(InxTaskCrnt).Comp)
If TaskComp(InxTaskCrnt).Comp(InxCompCrnt) = "" Then
Exit For
End If
Debug.Print Left(TaskComp(InxTaskCrnt).Comp(InxCompCrnt) & Space(5), 6);
Next
Debug.Print
Next
' Now place lists of Competencies in Column 2 against appropriate Task
RowCrnt = 2
With Worksheets("Sheet1")
TaskCrnt = .Cells(RowCrnt, 1).Value
Do While TaskCrnt <> ""
For InxTaskCrnt = 1 To InxTaskCrntMax
If TaskCrnt = TaskComp(InxTaskCrnt).Task Then
' Have found row in TaskComp that matches this row in worksheet
' Merge list of Competencies into a list separated by commas
CompListCrnt = Join(TaskComp(InxTaskCrnt).Comp, ",")
' Empty entries at the end of TaskComp(InxTaskCrnt).Comp will
' result in trailing commas. Remove them.
Do While Right(CompListCrnt, 1) = ","
CompListCrnt = Mid(CompListCrnt, 1, Len(CompListCrnt) - 1)
Loop
' and place in column 2
.Cells(RowCrnt, 2).Value = CompListCrnt
Exit For
End If
Next
RowCrnt = RowCrnt + 1
TaskCrnt = .Cells(RowCrnt, 1).Value
Loop
End With
End Sub
Sub DecodeCompencyTask(WShtName As String, ColComp As Long, ColTask As Long)
' Sheet WShtName contains two columns numbered ColComp and ColTask, Column
' ColComp contains one Competency per cell. Column ColTask holds a comma
' separated list of Tasks per cell. For each row, the Competency is gained
' by performing any of the Tasks.
' Scan the two columns. If a Task is missing from TaskComp() prepare a row
' for it. Add the Competency to the new or existing row for the Task.
Dim CompCrnt As String
Dim Found As Boolean
Dim InxCompCrnt As Long ' Index for Competencies for a Task
Dim InxTaskCrnt As Long ' Index for Tasks
Dim RowCrnt As Long
Dim TaskCrnt As Variant
Dim TaskList() As String
With Worksheets(WShtName)
RowCrnt = 2
Do While .Cells(RowCrnt, ColComp).Value <> ""
CompCrnt = .Cells(RowCrnt, ColComp).Value ' Extract Competency
' Remove any spaces from Task List and then split it
' so there is one Task per entry in TaskList.
TaskList = Split(Replace(.Cells(RowCrnt, ColTask).Value, " ", ""), ",")
' Process each task in TaskList
For Each TaskCrnt In TaskList
Found = False
' Look for current Task in existing rows
For InxTaskCrnt = 1 To InxTaskCrntMax
If TaskComp(InxTaskCrnt).Task = TaskCrnt Then
Found = True
Exit For
End If
Next
If Not Found Then
' New Task found. Prepare new row with Task but no
' Competencies
InxTaskCrntMax = InxTaskCrntMax + 1
If InxTaskCrntMax > UBound(TaskComp) Then
' No free rows in TaskComp. Add some more rows
ReDim Preserve TaskComp(1 To UBound(TaskComp) + 10)
End If
InxTaskCrnt = InxTaskCrntMax
TaskComp(InxTaskCrnt).Task = TaskCrnt
ReDim TaskComp(InxTaskCrnt).Comp(1 To 5)
' Rely on array entries being initialised to ""
End If
Found = False
' Look for an empty Competency slot in current row of TaskComp
For InxCompCrnt = 1 To UBound(TaskComp(InxTaskCrnt).Comp)
If TaskComp(InxTaskCrnt).Comp(InxCompCrnt) = "" Then
Found = True
Exit For
End If
Next
If Not Found Then
' Row is full. Add some extra entries and set InxCompCrnt to
' first of these new entries.
InxCompCrnt = 1 + UBound(TaskComp(InxTaskCrnt).Comp)
ReDim Preserve TaskComp(InxTaskCrnt).Comp(1 _
To UBound(TaskComp(InxCompCrnt).Comp) + 5)
End If
TaskComp(InxTaskCrnt).Comp(InxCompCrnt) = CompCrnt
InxCompCrnt = InxCompCrnt + 1
Next
RowCrnt = RowCrnt + 1
Loop
End With
End Sub